<commit_before>module Snap.Client where

import Control.Applicative ((<$>))
import Control.Category
import Prelude hiding ((.), id)
import Melchior.Control
import Melchior.Data.String
import Melchior.Dom
import Melchior.Dom.Events
import Melchior.Dom.Html
import Melchior.Dom.Selectors
import Melchior.EventSources.Mouse
import Melchior.EventSources.Elements
import Melchior.Remote.Json
import Melchior.Remote.XHR
import Melchior.Remote.Internal.ParserUtils
import Melchior.Sink

main :: IO ()
main = runDom client

client :: [Element] -> Dom ()
client html = do
  sendInputs html
  retrieveGets html

sendInputs :: [Element] -> Dom ()
sendInputs html = do
  titleInput <- Dom $ assuredly $ select (inputs . byId "set-title" . from) html
  codeInput <- Dom $ assuredly $ select (inputs . byId "set-code" . from) html
  pointsInput <- Dom $ assuredly $ select (inputs . byId "set-points" . from) html
  submit <- Dom $ assuredly $ select (byId "set-send" . from) html
  title <- return $ inputValue titleInput
  code <- return $ inputValue codeInput
  points <- return $ inputValue pointsInput
  clicks <- return $ click submit
  sets <- return $ remote POST "/post" $ (\_ -> toDto $ parseToJson (sample title) (sample code) (sample points)) <$> clicks
  terminate sets (\_ -> return ())

retrieveGets :: [Element] -> Dom ()
retrieveGets html = do
  textInput <- Dom $ assuredly $ select (inputs . byId "get-in" . from) html
  textSubmit <- Dom $ assuredly $ select (byId "get" . from) html
  textOut <- Dom $ assuredly $ select (byId "get-out" . from) html
  values <- return $ inputValue textInput
  clicks <- return $ click textSubmit
  gets <- return $ remote POST "/get" $ (\_ -> toDto $ json $ sample values) <$> clicks
  put textOut (((\s -> fromJson $ toJson $ process s) <$> gets) :: Signal Course)
  where json v = JsonObject [JsonPair (JsonString "name", JsonString $ jsStringToString v)]


process :: JSString -> JSString
process t = stringToJSString $ unescape $ trimTail $ trimHead s
  where s = jsStringToString t
        trimHead s = if (head s) == '"' then tail s else s
        trimTail s = if (last s) == '"' then (take ((length s)-1) s) else s
        unescape [] = []
        unescape (x:[]) = [x]
        unescape (x:y:xs) = if x == '\\' && y == '"' then unescape (y:xs) else x:(unescape (y:xs))

data Course = Course { title :: String, code :: Integer, points :: Integer }

instance JsonSerialisable Course where
  fromJson (Just c) = Course (stringOrError c "title")
                      (floor $ (read (stringOrError c "code") :: Float))
                      (floor $ (read (stringOrError c "points") :: Float))
  fromJson Nothing = Course "not found" (-1) (-1)<commit_msg>slightly compress setup by going straight to the value stream<commit_after>module Snap.Client where

import Control.Applicative ((<$>))
import Control.Category
import Prelude hiding ((.), id)
import Melchior.Control
import Melchior.Data.String
import Melchior.Dom
import Melchior.Dom.Events
import Melchior.Dom.Html
import Melchior.Dom.Selectors
import Melchior.EventSources.Mouse
import Melchior.EventSources.Elements
import Melchior.Remote.Json
import Melchior.Remote.XHR
import Melchior.Remote.Internal.ParserUtils
import Melchior.Sink

main :: IO ()
main = runDom client

client :: [Element] -> Dom ()
client html = do
  sendInputs html
  retrieveGets html

sendInputs :: [Element] -> Dom ()
sendInputs html = do
  title <- Dom $ (assuredly $ select (inputs . byId "set-title" . from) html) >>= \x -> return $ inputValue x
  code <- Dom $ (assuredly $ select (inputs . byId "set-code" . from) html) >>= \x -> return $ inputValue x
  points <- Dom $ (assuredly $ select (inputs . byId "set-points" . from) html) >>= \x -> return $ inputValue x
  submit <- Dom $ assuredly $ select (byId "set-send" . from) html
  clicks <- return $ click submit
  sets <- return $ remote POST "/post" $ (\_ -> toDto $ parseToJson (sample title) (sample code) (sample points)) <$> clicks
  terminate sets (\_ -> return ())

retrieveGets :: [Element] -> Dom ()
retrieveGets html = do
  values <- Dom $ (assuredly $ select (inputs . byId "get-in" . from) html) >>= \x -> return $ inputValue x
  textSubmit <- Dom $ assuredly $ select (byId "get" . from) html
  textOut <- Dom $ assuredly $ select (byId "get-out" . from) html
  clicks <- return $ click textSubmit
  gets <- return $ remote POST "/get" $ (\_ -> toDto $ json $ sample values) <$> clicks
  put textOut (((\s -> fromJson $ toJson $ process s) <$> gets) :: Signal Course)
  where json v = JsonObject [JsonPair (JsonString "name", JsonString $ jsStringToString v)]


process :: JSString -> JSString
process t = stringToJSString $ unescape $ trimTail $ trimHead s
  where s = jsStringToString t
        trimHead s = if (head s) == '"' then tail s else s
        trimTail s = if (last s) == '"' then (take ((length s)-1) s) else s
        unescape [] = []
        unescape (x:[]) = [x]
        unescape (x:y:xs) = if x == '\\' && y == '"' then unescape (y:xs) else x:(unescape (y:xs))

data Course = Course { title :: String, code :: Integer, points :: Integer }

instance JsonSerialisable Course where
  fromJson (Just c) = Course (stringOrError c "title")
                      (floor $ (read (stringOrError c "code") :: Float))
                      (floor $ (read (stringOrError c "points") :: Float))
  fromJson Nothing = Course "not found" (-1) (-1)
{'fraction_non_alphanumeric': 0.1363973313565604, 'fraction_numerical': 0.001111934766493699, 'mean_word_length': 3.324519230769231, 'pattern_counts': {'":': 0, '<': 37, '<?xml version=': 0, '>': 39, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2961381', 'n_tokens_mistral': 1708, 'n_tokens_neox': 1681, 'n_words': 574}