Henry Laxen April 24, 2013
Updated November 24, 2020

Background

First I would like to thank Chris Done and Adam Bergmark for their superb job in creating Fay, a way to write Javascript without writing Javascript. I've always disliked Javascript. I'm not sure why, but it is probably because of my Forth heritage. I remember a saying, I think by Bill Ragsdale: "Inside every big program is a small program trying to get out." That, for me, summarizes how I feel about Javascript. But now, thanks to Chris and Adam, I get to program in the best of all possible programming languages, Haskell. (My apologies to Voltaire.)

A couple of years ago, my friend Bonnie asked me to help her solve a Calcudoku puzzle. Rather than sit down and try to figure it out, I decided that since I was a powerful, master of the universe, Haskell programmer, I would just write a solver and short circuit all future questions. So I fired up emacs and went to the Calcudoku/ site, imported TagSoup, and started parsing. Next I wrote a solver, using Control.Monad.Logic, and voila, problem solved. However I didn't like that my solver was intimately tied to one website. I wanted a way to conveniently input a Calcudoku puzzle and get back a result. This meant I would have to write Javascript, and a lot of it. Sorry, no can do. Well, once Fay came along, I thought, why not finally write my inputter. While I was at it, I might as well document it so that it might still mean something to me in a couple of months, and perhaps help you, gentle reader, if you struggle with some the same issues I did.

Design

At this point you may want to take a peek at http://www.nadineloveshenry.com/calcudoku/index and scroll down to where you see the heading Enter the data yourself. There you will see a lonely select list, asking for the Puzzle Size. Once you select a puzzle size, a bunch of other widgets appear, waiting for your input. Obviously there is a lot of ajax going on behind the scenes.

In order to solve a Calcudoku puzzle, we need to know a few things. First the puzzle size. Next the range of values to be used for the puzzle data. Next the type of puzzle, there are three defined at the Calcudoku site, namely single puzzles, double puzzles, and so called killer puzzles. These are global pieces of data that describe the puzzle in general. Next each puzzle consists of regions, and each region has associated with it a value, an operator, and a set of cells. This code is supposed to make the input of this data the least tedious it can be. Once you enter the operator (from a select list) and a value in the text box, you should proceed to click on the cells that comprise the region. While entering the region, you can change the value and the operator, but once the region is finished, these cannot be changed. You can press [Enter] to complete the region, or click on the finish region button. Clicking on a cell while defining a region toggles its membership in the region, so if you accidently added a cell you didn't mean to add, just click on it again and you'll remove it from the region. Once you've finished a region, if you discover an error you can always remove regions in the reverse order in which they were defined by clicking on the discard last region button. Once the last region is finished, the data is sent to the server and the response is received and displayed. That's all there is to it!

Now that we know what we want to do, let's do it. As usual, I'll start at the bottom by first describing the types that we will use.

Shared Types

First a few words about why Fay is really amazing. It's all in the types, dude. The beauty of using Fay is that you can define your Types, use them in your Fay/Javascript client code, and then turn right around and use them in your Snap/Haskell server code. No converting to/from json or sql or strings or whatever. It is all done for you and you don't really have to care. This means you get that angel on your shoulder, the Haskell typechecker, for free. This alone is reason enough to use Fay, but for me the most compelling reason was still, it isn't javascript.

For starters, lets get the declarations and imports out of the way.

«sharedTypes imports»
{-# LANGUAGE CPP                      #-}
{-# LANGUAGE DeriveDataTypeable       #-}
{-# LANGUAGE OverloadedStrings        #-}

module Calcudoku.SharedTypes where

import Data.Text ( Text, empty )
import Data.Data ( Data, Typeable )
#ifdef FAY
import Data.Var
instance Read Text -- Sadly this was left out of Data.Text in fay-base
type World = Ref W
type UpdateW a = W -> a -> W
#endif
I define a couple of type synonyms to make things clearer, and then define the Coord type, which is just the row and column of a cell in the puzzle. The first time I wrote this, I just used a tuple for this, but Fay gave me a lot of trouble with that, (when I tried to encode and decode the data, and also with pattern matching) so I decided it was easier to just define a new data type and let emacs query-replace go to work for me.
«sharedTypes Coord»
type Row = Int
type Column = Int
type Value = Int
type Coord = (Row, Column)
type Should a = Either Text a

cRow :: Coord -> Row
cRow (row,_) = row

cColumn :: Coord -> Column
cColumn (_,col) = col

mkC :: Row -> Column -> Coord
mkC x1 x2 = (x1,x2)
Next are the data types for the operations and the puzzle type. The non commutative operations work as follows. For Minus one of the cells holds the first value and the rest are subtracted from it. Similar for Divide, one if the cells in the Divide region is the dividend, and the rest are the divisors. A Mod region can have two cells, and Id can only be a one cell region. I use Empty internally for a basically non-existant region.

The Subscriber PuzzleType constructor was an afterthought, and is not used in the Fay Client portion of the code. It us used in case the user tries to parse a puzzle from the calcudoku.org website that is for subscibers only.

«sharedTypes Region»
data Operation          = Plus   | Minus  | Times  | Divide | Power
                        | Or     | And    |  Mod   | Id     | Empty
  deriving (Data, Eq, Read, Show, Typeable)

defaultPuzzleType :: PuzzleType
defaultPuzzleType = NullP

data PuzzleType         = Single | Double | Killer | Subscriber | NullP
  deriving (Data, Eq, Read, Show, Typeable)

data Region             = Region {
  regionResult           :: Value,
  regionOperation        :: Operation,
  regionCoords           :: [Coord] }
  deriving (Data, Eq, Read, Show, Typeable)

emptyRegion :: Region
emptyRegion = Region 0 Empty []

Constraints are just lists of Regions, and a Board is a collection of data that totally defines the puzzle. Board is the important Data type that is shared between the client and the server.

«sharedTypes Board»
data Constraints        = Constraints
  { regions             :: [Region] }
  deriving (Data, Eq, Read, Show, Typeable)

data Board              = Board {
  puzzleType            :: PuzzleType,
  puzzleSide            :: Int,
  puzzleElementRange    :: [Int],
  puzzleConstraints     :: [Constraints] }
  deriving (Data, Eq, Read, Show, Typeable)
  -- puzzleConstraints is a list because when we solve a Double PuzzleType
  -- we use flipConstraints to switch the constraints from one board
  -- to another.  Thus head puzzleConstraints is the current list of Regions

defaultBoard :: Board
defaultBoard = Board NullP 0 [] []
After running this for a few months, I realized that editing existing puzzle boards was really a pain in the ..., so I impletment different modes to make editing easier. The original (and only mode) became ModeToggleCell. The ModeRemoveCell allows users to remove cells from any region. The ModeSelectRegion allows users to change regions, and finally ModeChangeValue lets users change the operator and/or value associated with a region.
«sharedTypes PuzzleMode»
data PuzzleMode =
  ModeToggleCell | ModeRemoveCell | ModeSelectRegion |  ModeChangeValue
  deriving (Data, Eq, Read, Show, Typeable)

Another feature I added is to run the solver in a seperate process from the web server. This allows the solver to run longer and not hang up the user. I need to send the data in the Shared data type to the solver process.
«sharedTypes Shared»
data Shared = Shared {
    sharedBoard     :: Board
  , sharedEvents    :: [CEvent]
  , sharedIPAddress :: Text
  , sharedURL       :: Text
  , sharedActualURL :: Text
  , sharedBgFile    :: Text
  , sharedPosted    :: Bool }
  deriving (Data, Eq, Read, Show, Typeable)

-- For some unknown reason, if this is defined outside of main
-- the JSON version of this data turns "" of type Text into an
-- empty array.

defaultText :: Text
defaultText = Data.Text.empty

defaultShared :: Shared
defaultShared = Shared defaultBoard [] defaultText defaultText defaultText defaultText True

Client Types

There is one more type I need for the client, but I don't need it for the server. One of the nice things anansi does for me is it allows me to define things in a logical order and place, and then move them around into seperate files like Haskell likes. So the following data type actually appears in a file called ClientTypes.hs, even though I define it here along with all of the shared types. Because the Fay client code needs a notion of the current region, I added a simple data type, used throughout the client, that includes a Board and the current region.

After running this for a few days, I started getting emails that the puzzle didn't have a solution. I needed a way for the user to be able to send me the data that he input, so I could take a look at it. That required a new datatype, the CEvent. Each CEvent corresponds to a user's action. By replaying the user input, I can debug anything that goes wrong in the Fay code, as well as make sure the solver is running correctly. So far, all of the errors have been mistakes on the data entry part. This means I need to rethink how to make the data entry simpler and need to figure out a convenient way to edit already entered data.

«clientTypes World»
data W = W {
    board                 :: Board      -- The puzzle board
  , currentRegionIndex    :: Maybe Int  -- If we have a current region
                                        -- this is the index into the
                                        -- puzzleConstraints list
  , editing               :: PuzzleMode -- the current editing mode
  , cevents               :: [CEvent]   -- a list of user generated
                                        -- browser events
    }
  deriving (Data, Eq, Read, Show, Typeable)

defaultW :: W
defaultW = W (Board NullP 0 [] [Constraints []]) Nothing ModeToggleCell []
«sharedTypes CEvent»
data CEvent =
               P PuzzleType Int [Int]   -- Type Size Range
             | D Int Int                -- Discard region containing x,y
             | L Int Int                -- l on cell x y
             | M PuzzleMode             -- change editing mode
             | R (Maybe Int)            -- change current region
             | V Operation Int          -- change op and value of region
             | N Int Int Operation Int  -- add a new region

  deriving (Data, Eq, Read, Show, Typeable)

Maps

Well, there aren't instances in Fay, and there aren't even maps, but as every good lisp programmer knows, you don't really need all that fluff as long as you have lists. I need to represent operations three different ways. One as a haskell data type, two as a string that gets put in the value field of an option html element, and three as the text associated with that value that is displayed to the user. These maps allow me to translate from any one of these representations to another. Painful but necessary.
«maps definitions»
valueToOperationMap :: [(Text, Operation)]
valueToOperationMap = [
      ("Id"    , Id)
    , ("Plus"  , Plus)
    , ("Minus" , Minus)
    , ("Times" , Times)
    , ("Divide", Divide)
    , ("Power" , Power)
    , ("Mod"   , Mod)
    , ("And"   , And)
    , ("Or"    , Or)
    , ("Empty" , Empty)
  ]

valueToOperationTextMap :: [(Text, Text)]
valueToOperationTextMap = [
     ("", "Select operator for region")
        , ("Id"     , "=")
        , ("Plus"   , "+")
        , ("Minus"  , "-")
        , ("Times"  , "*")
        , ("Divide" , "/")
        , ("Power"  , "^")
        , ("Mod"    , "mod")
        , ("And"    , "&")
        , ("Or"     , "|")
  ]

operationToTextMap :: [(Operation, Text)]
operationToTextMap = [
          (Id     , "=")
        , (Plus   , "+")
        , (Minus  , "-")
        , (Times  , "*")
        , (Divide , "/")
        , (Power  , "^")
        , (Mod    , "mod")
        , (And    , "&")
        , (Or     , "|")
  ]

-- valueToOperationTextMap :: [(Text, Text)]
-- valueToOperationTextMap = [
--      ("", "Select operator for region")
--         , ("Id"     , "=")
--         , ("Plus"   , "+")
--         , ("Minus"  , "-")
--         , ("Times"  , "×")
--         , ("Divide" , "÷")
--         , ("Power"  , "^")
--         , ("Mod"    , "mod")
--         , ("And"    , "∧")
--         , ("Or"     , "∨")
--   ]
-- 
-- operationToTextMap :: [(Operation, Text)]
-- operationToTextMap = [
--           (Id     , "=")
--         , (Plus   , "+")
--         , (Minus  , "-")
--         , (Times  , "*")
--         , (Divide , "/")
--         , (Power  , "^")
--         , (Mod    , "%")
--         , (And    , "&")
--         , (Or     , "|")
--   ]

xoperationToTextMap :: [(Operation,Text)]
xoperationToTextMap =
  let
    textOps = 
      map (\x -> fromMaybe (error . unpack $ "Missing op")
        (lookup x valueToOperationTextMap)) (map fst valueToOperationMap)
    opNames = map snd valueToOperationMap
    in zip opNames textOps
You'ld think I'ld need the same three representations for the PuzzleType data type, but I thought I'ld implement it differently by having the option elements already populate the html file. Just like Perl, tmtowtdi. I also have explanations associated with each PuzzleType that are displayed to the user and stored as hidden elements in the html page.
«maps puzzleMaps»
puzzleTypeMap :: [(Text, PuzzleType)]
puzzleTypeMap = [
    ("Single"     , Single)
  , ("Double"     , Double)
  , ("Killer"     , Killer)
  , ("Subscriber" , Subscriber)
  , ("NullP"      , NullP)]

puzzleModeMap :: [(Text, PuzzleMode)]
puzzleModeMap = [
     ( "ModeToggleCell"   ,  ModeToggleCell )
  ,  ( "ModeRemoveCell"   ,  ModeRemoveCell )
  ,  ( "ModeSelectRegion" ,  ModeSelectRegion )
  ,  ( "ModeChangeValue"  ,  ModeChangeValue ) 
  ]

explainMap :: [(PuzzleType, Text)]
explainMap = [
      (Single , "#explainCreateRegion")
    , (Double , "#explainCreateRegion")
    , (Killer , "#explainKillerCreateRegion") ]

Updaters

Another thing lacking from Fay is the State Monad, so one workaround is to pass the state into every function that needs it. That's where the World comes in. The World type is a reference to the W type defined above. References are defined in the JQBindings code above, and allow you to have mutable variables in the Fay monad. All we need now is a COMMON block and it's just like programming in Fortran all over again. ;-)

So a World is a reference to a W, and and UpdateW is a function that updates a subfield of a W. Here are all the various updaters we need. Makes you appreciate Lenses, which aren't available in Fay.

«updaters code»
updateSide :: UpdateW Int
updateSide w v = w { board = (board w) { puzzleSide = v}}
updatePuzzleType :: UpdateW PuzzleType 
updatePuzzleType w v = w { board = (board w) { puzzleType = v}}
updateElementRange :: UpdateW [Int]
updateElementRange w v = w { board = (board w) { puzzleElementRange = v}}

updateLow :: UpdateW Int
updateLow w v = w { board = (board w)
 { puzzleElementRange = [v .. (Prelude.last . puzzleElementRange . board $ w)]}}
updateHigh :: UpdateW Int
updateHigh w v = w { board = (board w)
 { puzzleElementRange = [(Prelude.head . puzzleElementRange . board $ w) .. v]}}
updateAll w v = w { board = (board w) { puzzleSide = v, puzzleElementRange = [1..v] }}


currentRegion :: W -> Region
currentRegion w =
  maybe (tError "currentRegion is Nothing") thisRegion (currentRegionIndex w)
  where
    thisRegion i = (regions $ currentConstraints w) !! i

currentConstraints :: W -> Constraints
currentConstraints w = if Prelude.null p then tError "currentConstraints is null" else Prelude.head p
  where p = puzzleConstraints . board $ w

currentRegionCoords :: W -> [Coord]
currentRegionCoords w = maybe [] theseCoords (currentRegionIndex w)
  where
    theseCoords _ = regionCoords . currentRegion $ w

updateCurrentRegion :: UpdateW Region
updateCurrentRegion w r =
  let
    b = board w
    allRegions = regions . currentConstraints $ w
    newW = case (currentRegionIndex w) of
      Nothing -> 
        let
          newRegions = r : allRegions
          newC = Constraints newRegions : Prelude.tail (puzzleConstraints b)
          newB = b { puzzleConstraints = newC }
        in w { board = newB, currentRegionIndex = Just 0 }
      Just i ->
        let
          regionIsEmpty = Prelude.null . regionCoords
          (before,after) = splitAt i allRegions
          newRegions = if regionIsEmpty r then before ++ (Prelude.tail after)
                         else before ++ [r] ++ (Prelude.tail after)
          newC = Constraints newRegions : Prelude.tail (puzzleConstraints b)
          newB = b { puzzleConstraints = newC }
          w1 = if regionIsEmpty r then w { currentRegionIndex = Nothing } else w
          w2 = w1 { board = newB }
        in w2
    in newW

isNewRegion :: W -> Bool
isNewRegion w = maybe True (const False) (currentRegionIndex w)

removeEmptyRegions :: W -> W
removeEmptyRegions w =
  let
    b = board w
    allRegions :: W -> [Region]
    allRegions = regions . currentConstraints
    nonEmptyRegions :: W -> [Region]
    nonEmptyRegions = filter hasCells . allRegions
    hasCells :: Region -> Bool
    hasCells  = not . Prelude.null . regionCoords
    newB = b { puzzleConstraints = Constraints (nonEmptyRegions w)
                                   : Prelude.tail (puzzleConstraints b) }
    newW = w { board = newB }
  in newW

Picklers

I wrote this code in 2020, after noticing that my previous version, which used Aeson and Fay.Convert seemed to be very fragile. I made some minor changes to the Shared data type and all hell broke loose. Also it was extremely difficult to track down parsing errors that were happening in 30K bundles of packed text.

So here is the GHC/Fay compatibility layer. It encodes/decodes Text, Ints, Lists of Ints, and Bools. Everything else is express in terms of it.

«pickle compat»

decodeBool :: Text -> Bool
decodeBool x = x == "True" || x == "true"

#ifdef FAY
encodeInt :: Int -> Text
encodeInt = ffi "JSON.stringify(%1)"
decodeInt :: Text -> Int
decodeInt = ffi "parseInt(%1)"
decodeIntList :: Text -> [Int]
decodeIntList = ffi "JSON.parse(%1)"
encodeIntList :: [Int] -> Text
encodeIntList = ffi "JSON.stringify(%1)"
encodeBool :: Bool -> Text
encodeBool b = if b then "true" else "false"
sortIntList :: [(Int,Int)] -> [(Int,Int)]
sortIntList = ffi "%1.sort(  (function(x,y) { \
  \ if (x[0] == y[0]) {return (x[1]-y[1])} else {return (x[0]-y[0])} ;}))"
#else

decodeFromText :: Read a => Text -> a
decodeFromText = read . unpack
encodeInt :: Int -> Text
encodeInt = pack . show
decodeInt :: Text -> Int
decodeInt = decodeFromText
decodeIntList :: Text -> [Int]
decodeIntList = decodeFromText
encodeIntList :: [Int] -> Text
encodeIntList = pack . show
encodeBool :: Bool -> Text
encodeBool = pack . show
sortIntList :: [(Int,Int)] -> [(Int,Int)]
sortIntList = sort
deblank :: Text -> Text
deblank = Data.Text.filter nonWhiteSpace
  where
    nonWhiteSpace c = not (c `Prelude.elem` whiteSpace)

#endif
Here we go through each data type to build our way up to the Shared type, which is how the server (ghc) communicates with the broswer (fay). I start with the delimiters that we use.
«pickle chars»
comma, underscore, space, newLine :: Text
comma = ","
underscore = "_"
space = " "
newLine = "\n"
whiteSpace :: [Char]
whiteSpace = [ ' ', '\n', '\t' ]
I am assuming here that the text I am encoding does NOT contain brackets or commas. Since in my case the text is a bunch of filenames or urls, mostly generated by me, this is a safe assumption.
«pickle text»
encodeSafeTextList :: [Text] -> Text
encodeSafeTextList = encloseWith "[]" . (Data.Text.intercalate (comma <> newLine))
decodeSafeTextList :: Text -> [Text]
decodeSafeTextList = balancedBreakText comma . deEnclose
«pickle code»
encloseWith :: Text -> Text -> Text
encloseWith brackets txt = Data.Text.head brackets `cons` txt `snoc` Data.Text.last brackets

deEnclose :: Text -> Text
deEnclose = Data.Text.init . Data.Text.tail

deList :: Text -> [Text]
deList = Data.Text.splitOn comma . deEnclose
               
encodeIntPair :: (Int,Int) -> Text
encodeIntPair (x,y) = encloseWith "()" (encodeInt x <> comma <> encodeInt y)
decodeIntPair :: Text -> (Int,Int)
decodeIntPair txt = if confirm then (decodeInt i1, decodeInt i2) else error (unpack "decodeIntPair")
  where
    Just (p1,r1) = uncons txt
    [i1,t2] = splitOn comma r1
    i2 = Data.Text.init t2
    p2 = Data.Text.last t2
    confirm = p1 == '(' && p2 == ')' 

-- !!! Note !!! the IntPairList that comes out of encode is SORTED
encodeIntPairList :: [(Int,Int)] -> Text
encodeIntPairList ps = encloseWith "[]" (Data.Text.intercalate (comma <> space) (Prelude.map encodeIntPair . sortIntList $ ps))
decodeIntPairList :: Text -> [(Int,Int)]
decodeIntPairList = Prelude.map decodeIntPair . joinTextPairs . deList
  where
    joinTextPairs :: [Text] -> [Text]
    joinTextPairs txts = go [] txts
      where
        go acc [] = Prelude.reverse acc
        go acc (x:y:rest) = go (x<>comma<>y:acc) rest
        go acc rest = error (Prelude.unwords . map unpack $ ["joinTextPairs:"] ++ acc ++ rest)


unEither :: Either c c -> c
unEither = either id id
unLeft :: Either Text c -> c
unLeft = either (\x -> (error . unpack $ ("unLeft " <> x))) id

balancedBreakText :: Text -> Text -> [Text]
balancedBreakText delimiterText text = Prelude.map pack result
  where
    result = balancedBreak (unpack delimiterText) (unpack text)

encodeOperation :: Operation -> Text
encodeOperation = unEither . showLookup "encodeOperation error "  valueToOperationMap
decodeOperation :: Text -> Operation
decodeOperation = unLeft . readLookup "decodeOperation error " valueToOperationMap

encodePuzzleType :: PuzzleType -> Text
encodePuzzleType = unEither . showLookup "encodePuzzleType error " puzzleTypeMap
decodePuzzleType :: Text -> PuzzleType
decodePuzzleType = unLeft . readLookup "decodePuzzleType error " puzzleTypeMap

encodePuzzleMode :: PuzzleMode -> Text
encodePuzzleMode = unEither . showLookup "encodePuzzleMode error " puzzleModeMap
decodePuzzleMode :: Text -> PuzzleMode
decodePuzzleMode = unLeft . readLookup "decodePuzzleMode error " puzzleModeMap

encodeCEvent :: CEvent -> Text
encodeCEvent cev = case cev of
  P x1 x2 x3  -> Data.Text.intercalate underscore
    [ "P" , encodePuzzleType x1, encodeInt x2, encodeIntList x3 ]
  L x1 x2     -> encodeWith2Ints "L" x1 x2
  D x1 x2     -> encodeWith2Ints "D" x1 x2
  M x1        -> "M_" <> encodePuzzleMode x1
  R Nothing   -> "R_N"
  R (Just x1) -> "R_J_" <> encodeInt x1
  V x1 x2     -> Data.Text.intercalate underscore
    [ "V" , encodeOperation x1, encodeInt x2]
  N x1 x2 x3 x4 -> Data.Text.intercalate underscore
    [ "N", encodeInt x1, encodeInt x2, encodeOperation x3, encodeInt x4 ]
  where
    encodeWith2Ints str i1 i2 = Data.Text.intercalate underscore
      [ str , encodeInt i1, encodeInt i2]

cEventMap :: [(Text, [Text] -> CEvent)]
cEventMap = [
    ("P" , \x -> P (decodePuzzleType (x!!1)) (decodeInt (x!!2)) (decodeIntList (x!!3)) )
  , ("L" , \x -> L (decodeInt (x!!1)) (decodeInt (x!!2)) )
  , ("D" , \x -> D (decodeInt (x!!1)) (decodeInt (x!!2)) )
  , ("M" , \x -> M (decodePuzzleMode (x!!1)) )
  , ("R" , \x -> R (if (x!!1) == "N" then Nothing else Just (decodeInt (x!!2))) )
  , ("V" , \x -> V (decodeOperation (x!!1)) (decodeInt (x!!2)) )
  , ("N" , \x -> N (decodeInt (x!!1)) (decodeInt (x!!2)) (decodeOperation (x!!3)) (decodeInt (x!!4)) ) ]

decodeCEvent :: Text -> CEvent
decodeCEvent txt = case mbF of
  Nothing -> error (unpack $ "decodeCEvent: " <> txt)
  Just f  -> f a
  where
    a = splitOn underscore txt
    mbF = lookup (Prelude.head a) cEventMap

encodeCEvents :: [CEvent] -> Text
encodeCEvents =  encloseWith "[]" . Data.Text.intercalate comma . (Prelude.map encodeCEvent)
decodeCEvents :: Text -> [CEvent]
decodeCEvents txt = if cs == [""] then [] else  Prelude.map decodeCEvent $ cs
  where
    cs = balancedBreakText comma . deEnclose $ txt

encodeRegion :: Region -> Text
encodeRegion (Region v o cs) = "\nRegion_" <>
  Data.Text.intercalate underscore
    [encodeInt v, encodeOperation o, encodeIntPairList cs]

decodeRegion :: Text -> Region
decodeRegion txt = (confirm region) (decodeInt result) (decodeOperation op) (decodeIntPairList coords)
  where
    [region,result,op,coords] = splitOn underscore txt
    confirm x = if x == "Region" then Region else error (unpack $ "decodeRegion: " <> txt)

encodeConstraint :: Constraints -> Text
encodeConstraint (Constraints cs) =
  "Con_" <> encloseWith "[]" (Data.Text.intercalate comma (Prelude.map encodeRegion cs))
decodeConstraint :: Text -> Constraints
decodeConstraint txt = (confirm constraint) (Prelude.map decodeRegion regs)
  where
    [constraint,rs] = [Data.Text.take 4 txt, Data.Text.drop 4 txt]
    regs = balancedBreakText comma . deEnclose $ rs
    confirm x = if x == "Con_" then Constraints else error (unpack $ "decodeConstraints: " <> txt)

encodeConstraints :: [Constraints] -> Text
encodeConstraints = encloseWith "[]" . (Data.Text.intercalate (comma <> space)) . (Prelude.map encodeConstraint)
decodeConstraints :: Text -> [Constraints]
decodeConstraints csl =  if csl == "[]" then [] else Prelude.map decodeConstraint . cs $ csl
  where
    cs = balancedBreakText comma . deEnclose
    
encodeBoard :: Board -> Text
encodeBoard (Board pt ps pe pc) =  encloseWith "[]" . (Data.Text.intercalate comma) $
    [ "Bo", encodePuzzleType pt, encodeInt ps, encodeIntList pe, encodeConstraints pc]
decodeBoard :: Text -> Board
decodeBoard txt =  ((confirm bo) (decodePuzzleType pt) (decodeInt ps) (decodeIntList pe) (decodeConstraints pc))
   where
     [bo, pt, ps, pe, pc] =  balancedBreakText comma . deEnclose $ txt
     confirm x = if x == "Bo" then Board else error (unpack $ "decodeBoard: " <> txt)
                           
encodeShared :: Shared -> Text
encodeShared (Shared bd cs t1 t2 t3 t4 b) = encodeSafeTextList $
  (["Sh", encodeBoard bd, encodeCEvents cs] ++ 
   [encodeSafeTextList [t1,t2,t3,t4]] ++ [encodeBool b])
decodeShared :: Text -> Shared
decodeShared txt = (confirm sh) (decodeBoard bd) (decodeCEvents cs) t1 t2 t3 t4 (decodeBool b)
  where
    [sh, bd, cs, txts, b] = decodeSafeTextList $ deblank txt
    [t1, t2, t3, t4] = decodeSafeTextList txts
    confirm x = if x == "Sh" then Shared else error (unpack $ "decodeShared: " <> txt)
«pickle test»
#ifdef Fay
pickleTest :: Fay ()
#else
pickleTest :: IO ()
#endif
pickleTest = do
  let
    r1 = Region 1 Plus [(1,2),(3,4)]
    r2 = Region 2 Times [(4,5),(6,7)]
    c1 = Constraints [r1,r2]
    c2 = Constraints [r2,r1]
    c3 = [c1,c2]
    b1 = Board Single 3 [-1,0,1] [c1]
    ce1 = P Single 1 [-1,0,1]
    ce2 = D 1 2
    ce3 = L 3 4
    ce4 = M ModeChangeValue
    ce5 = R (Just 1)
    ce6 = V Divide 2
    ce7 = N 1 2 Minus 3
    ces = [ce1, ce2, ce3, ce4, ce5, ce6, ce7]
    s1 = Shared b1 ces "127.0.0.1" "!^withHat1^" "!^withHat2^" "!^withHat3^" True
    round1 = decodeRegion . encodeRegion 
    round2 = decodeConstraints . encodeConstraints
    round3 = decodeBoard . encodeBoard
    round4 = decodeCEvent . encodeCEvent
    round5 = decodeCEvents . encodeCEvents
    round6 = decodeShared . encodeShared
  print $ encodeConstraint c1
  print (round1 r1)
  print (round2 c3)
  print (round3 b1)
  print (encodeBoard b1)
  mapM_ print (Prelude.map  encodeCEvent ces)
  mapM_ print (Prelude.map round4 ces)
  print (encodeCEvents ces)
  mapM_ print $ (round5 ces)
  print (encodeShared s1)
  print (round6 s1)

Color List

I need to display the different regions in different background colors, so here are the ones that I chose. If we have more regions than that, we wrap around
«shared colorList»
backgroundColorList :: [Text]
backgroundColorList = map pack [
    "DarkCyan"
  , "DarkGoldenRod"
  , "DarkGreen"
  , "DarkKhaki"
  , "DarkMagenta"
  , "DarkOliveGreen"
  , "Darkorange"
  , "DarkOrchid"
  , "DarkRed"
  , "DarkSalmon"
  , "DarkSeaGreen"
  , "DarkSlateBlue"
  , "DarkSlateGray"
  , "DarkTurquoise"
  , "DarkViolet"
  , "DeepPink"
  , "DeepSkyBlue"
  , "FireBrick"
  , "ForestGreen"
  , "HotPink"
  , "IndianRed"
  , "Indigo"
  , "Maroon"
  , "MidnightBlue"
  , "OrangeRed"
  , "Peru"
  , "RoyalBlue"
  , "SlateGray"
  ]

jQuery Bindings

Even though Fay is Haskell, it is not all of Haskell. In particular, I've found that a lot of read and show instances you take for granted in regular Haskell don't work in Fay. The way around it is to write a bunch of functions with specific types so that the underlying JSON.stringify function does the right thing. Most of this code was ripped from the examples that came with Fay, so I won't go into details here. Also the fay-jquery module continues to change, so please look there to see what is going on. I'll just include a few examples of the functions I defined here, and hide the rest from your gaze.
«jqbindings exposed»

windowConfirm :: Text -> Fay Bool
windowConfirm = ffi "window.confirm(%1)"

simpleClone :: JQuery -> Fay JQuery
simpleClone = ffi "%1['clone']()"

stopImmediatePropagation :: Event -> Fay ()
stopImmediatePropagation = ffi "%1['stopImmediatePropagation']()"

jPostBoard :: Text -> Text -> (Text -> Fay ()) -> Fay ()
jPostBoard = ffi "jQuery.ajax(%1, { data: %2, type: 'POST', processData: false, contentType: 'text/json', success: %3 })"

Shared Utils

These are shamelessly copied from Data.List. Since I need them for my Fay code, it thought they might come in handy in the server code too, and there is no reason to not share them.
«shared utils 1»
reverseMap :: [(a,b)] -> [(b,a)]
reverseMap = Prelude.map (\x -> (snd x, fst x))
                     
readLookup :: Eq a => Text -> [(a,b)] -> a -> Should b
readLookup msg l x = maybe (Left msg) Right $ lookup x l

showLookup :: Eq b => Text -> [(a,b)] -> b -> Should a
showLookup msg l x = maybe (Left msg) Right $ lookup x (reverseMap l)

zeroFill :: Show a => Int -> a -> Text
zeroFill n x = pack $ replicate k '0' ++  show x
  where k = n - length (show x)

chop :: Int -> [a] -> [[a]]
chop _ [] = []
chop n xs = take n xs : chop n (drop n xs)

merge2 :: [a] -> [a] -> [a]
merge2 = m2 []
  where
    m2 acc x [] = acc ++ x
    m2 acc [] x = acc ++ x
    m2 acc (x:xs) (y:ys) = m2 (acc ++ [x,y]) xs ys

circularNext :: Eq a => [a] -> a -> [a]
circularNext l wanted = cn l []
  where
    cn [] _ = []
    cn (x:xs) acc = if x == wanted
                    then xs ++ acc ++ [x]
                    else cn xs (acc ++ [x])

padList :: [[a]] -> [[a]]
padList l =
  let
    maxLength = maximum . map length $ l
    pad1 x = if length x < maxLength 
             then take maxLength . concat . repeat $ x
             else x
  in map pad1 . filter (not . null) $ l                 

split :: Char -> String -> [String]
split c str = words' (dropWhile isC str)
  where words' []  = []
        words' s = case break isC s of (a,b) -> a : (split c) b
        isC = (==c)

isPrefixOf              :: (Eq a) => [a] -> [a] -> Bool
isPrefixOf [] _         =  True
isPrefixOf _  []        =  False
isPrefixOf (x:xs) (y:ys)=  x == y && isPrefixOf xs ys

isSuffixOf              :: (Eq a) => [a] -> [a] -> Bool
isSuffixOf x y          =  reverse x `isPrefixOf` reverse y

isInfixOf               :: (Eq a) => [a] -> [a] -> Bool
isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)

tails                   :: [a] -> [[a]]
tails xs                =  xs : case xs of
                                  []      -> []
                                  _ : xs' -> tails xs'

breakNear :: Int -> Char -> String -> [String]
breakNear i c str = go str []
  where
    go "" acc = concat . reverse $ acc
    go s acc =
      let
        (before,after) = splitAt i s
        (extra,rest) = break (== c) after
      in go rest ([before ++ extra] : acc)

Miscellaneous Utilities

Everybody needs a module where you stick things that don't really belong anywhere else. Welcome to the Utils module. With Fay you often find yourself stringing together a bunch of jquery calls. The & function is just a rebinding of >>= which is more convenient to use.
debug appends a jquery element to my span identified the the #debug id. It makes it easier to dump stuff to chome when I'm not sure what is being passed back and forth.
selectId just selects the DOM element with the specified id. I got tired of always typeing "#".
«utils 1»
debug :: JQuery -> Fay ()
debug x = do
  d <- selectId "debug"
  appendTo d x & hvoid

hvoid :: a -> Fay ()
hvoid _ = return ()
englishInt does very simple grammatical correctness for nouns whose plural end with s.
splitWith takes a Char and a String and splits the string into a list of strings, removing the Char from the list. Just like Perl's split function.
idFromCoord and coordFromId are inverses. They transforms a Coord type into a string suitable for insertion into the DOM as an id.
hvoid is used often to make the types come out right. Generally in Fay you are returning a Fay (), but sometimes your last statement returns a Fay Notvoid, so just append a & hvoid to the function and you're golden.
Void used to exist in the Prelude defined by Fay, but the definition changed and it was easier to do a global replace of void with hvoid instead of rewrite everything.
«utils 2»
idFromCoord :: Coord -> Text
idFromCoord (r,c)  = "T" <> Data.Text.intercalate "_" [showInt r, showInt c]

coordFromId :: Text -> Coord
coordFromId str =
  let
    digitTexts = split "_" (Data.Text.tail str)
    ints = Prelude.map readInt digitTexts
  in ((ints!!0) , (ints!!1))
doubleQuote - I got tired of escaping everything, and solved it with this simple function.
For some reason mapM isn't included (yet) in Fay's Prelude, so here it is.
exposeIds and hideIds are inverses, and just remove or add the hidden class to a list of elements with the given ids.
The three set functions just set the contents of various spans and divs I've defined. Nothing profound.
I tried this out on an ipad, and the keyboard kept popping up, so I need to see if I'm running on a tablet and disable the checkForEnter feature when inputting the squares.
«utils 3»
setError :: Text -> Fay ()
setError msg = do
  statusError <- selectId "statusError"
  case msg of
    "" -> Fay.SafeJQuery.empty statusError & removeClass "error"
    _  -> appendText msg statusError & addClass "error"
  return ()

setExplain :: Text -> Fay ()
setExplain explainId = do
  explain <- selectId explainId & contents & simpleClone
  selectId "instructions" & Fay.SafeJQuery.empty & appendJQuery explain & hvoid

setStatus :: Text -> Text -> Fay ()
setStatus statusId msg = do
  status <- selectId statusId
  setHtml msg status & hvoid

whenTablet :: a -> (a -> Fay ()) -> (a -> Fay ()) -> Fay ()
whenTablet arg trueFun falseFun = do
  agent <- windowUserAgent
  let
    isTablet = "iPhone" `isInfixOf` agent || "iPad" `isInfixOf` agent
  if isTablet then trueFun arg else falseFun arg

-- Monadic fold over the elements of a structure,
-- associating to the left, i.e. from left to right.
foldM :: (a -> b -> Fay a) -> a -> [b] -> Fay a
foldM f z0 xs = foldr f' return xs z0
  where f' x k z = f z x >>= k

The Calcudoku Client

So here is the meat and potatoes of the App. The general idea for a Handler is to update the state of the World based on the Event received, and do whatever Fay actions are necessary. main just waits for the document to be ready, creates a new reference to W, and starts by setting up the size selection widget.

Also I check to see if the query parameter is debug, and if so a couple of addtional text inputs show up on the page at the top. These allow me to input the parsed board or the input log into the textbox and let the server crunch.

«client initialize»
type Handler a = World -> a -> Fay ()
type EventHandler = Handler Event
type CellHandler  = Handler Coord

main :: Fay ()
main =  ready $ newRef defaultW & initialize

initialize :: World -> Fay ()
initialize world =  do
  d <- Calcudoku.Client.isDebug
  purifyConfig
  let
    sizeRange = if d then [2..15] else [4..15]
  setupSize world sizeRange
  when d $ do
    (exposeIds ["debug", "debug-input", "debug-show"])
    set world defaultW
    setupPuzzleMode world
    setupRange world 2
    setupPuzzleTable world
    setupOperators world
    exposeIds ["range", "operator", "resultSpan" , "finish", "editingSpan"]

isDebug :: Fay Bool
isDebug = do
  url <- windowUrl
  let
    debug = T.unpack "debug" 
    queryParms = dropWhile (/= '?') (T.unpack url)
    isDebug = not (null queryParms) && debug == (take (length debug) . tail $ queryParms)
  return isDebug
As the COBOL people like to say, numberOfRegionsDefined and numberOfSquaresToGo are self documenting, so I'll just explain what is going on in updateBoard. I wanted to have all singleton entries, ie cells whose operation is id, be the color white, all cells that aren't part of a region, either existing or being formed, be AliceBlue, cells that are part of the region being created be DeepSkyBlue, and the rest, the already existing regions be various different colors as defined by the backgroundColorList. Additionally, the first cell in every region should contain the operation and value for that region.
«client regions»
------------------------------ Regions ------------------------------

numberOfRegionsDefined :: W -> Int
numberOfRegionsDefined = length . regions . currentConstraints

numberOfSquaresToGo :: W -> Int
numberOfSquaresToGo w = total - alreadyDefined
  where
    total = (puzzleSide . board $ w)^2
    alreadyDefinedList = map (length . regionCoords) . regions . currentConstraints $ w
    alreadyDefined = if null alreadyDefinedList then 0 else sum alreadyDefinedList

This code divides the regions into the different classes I want to represent with a distinct background colors. rs is a list of all the exsiting regions. c is a list of lists of the co-ordinates of these regions. singletons filters c and keeps just the co-ordinates that have only length 1 regions. These correspond to regions that are associated to the = (id) operation. multiples are the list of co-ordinates with more than 1 cell in their regions. unmarked are cells that are not part of an existing finished region. Finally, beingDefined are the co-ordinates of the region currently being defined. Each of these types of cells are zipped together with their background color as described above. Finally allRegions is a list of all non-empty regions, even the one that is currently being defined and hasn't yet been completed.
«client regions 1»
updateBoard :: W -> Fay ()
updateBoard w = do
  let
    rs :: [Region]
    rs = reverse . regions . currentConstraints $ w
    c :: [[Coord]]
    c = map regionCoords rs
    n =  puzzleSide . board $ w
    allCoords = [ (i, j) | i <- [ 1 .. n] , j <- [1 .. n] ]
    singleTons :: [[Coord]]
    singleTons = filter ((== 1) . length) c
    multiples :: [[Coord]]
    multiples  = filter ((/= 1) . length) c
    unmarked :: [[Coord]]
    unmarked = [filter (\x -> x `notElem` (concat c)) allCoords]
    beingDefined :: [[Coord]]
    beingDefined = [currentRegionCoords w]

    white :: [ ([Coord],Text) ]
    white = zip singleTons (repeat "White")
    colored :: [ ([Coord],Text) ]
    colored = zip multiples (concat . repeat $ backgroundColorList)
    yellow = zip unmarked (repeat "Yellow")
    red = zip beingDefined (repeat "Red")
    allRegions :: [Region]
    allRegions = regions . currentConstraints $ w
This double loop sets the background color of all the regions. It also resets the attributes and the values of each cell. They will be filled back in later, depending on their type.
«client regions 2»
  forM_ (white ++ colored ++ yellow ++ red) $ \i -> do
    let
      cells = fst i
      color = snd i
    forM_ cells $ \j -> do
      cell <- selectCell j
      let v = T.intercalate "" ["background-color:", color, ";"]
      setAttr "style" v cell &
        removeClass "cellConstrained"
      setVal "" cell
This double loop adds back the cellConstrained class to each region that is already defined and completed.
«client regions 3»
  forM_ (white ++ colored) $ \i -> do
    let
      cells = fst i
      color = snd i
    forM_ cells $ \j -> do
      cell <- selectCell j
      addClass "cellConstrained" cell
This loop restores the operation and the value for the first cell in every region.
«client regions 4»
  forM_ allRegions $ \g ->
    when (not (null (regionCoords g))) $ do
      firstCell <- selectCell . head . regionCoords $ g
      let
        operator = regionOperation g
        opText = maybe "" id $ lookup operator operationToTextMap
        value = showInt . regionResult $ g
      setVal (value <> opText) firstCell & hvoid

  selectId (encodePuzzleMode (editing w) <> "id") & checked & hvoid
  return ()

selectCell :: Coord -> Fay JQuery
selectCell c = do
  let cellId = idFromCoord c
  selectId cellId 
doRegionsExist simple checks whether any regions have been defined or are being defined. resetRegions resets the state of the World back to when no regions are yet defined. This is called if the user changes the size or type of the puzzle.
«client regions 5»
doRegionsExist :: World -> Fay Bool
doRegionsExist world = do
  w <- get world
  return $ numberOfRegionsDefined w > 0

resetRegions :: World -> Fay ()
resetRegions world = do
  w <- get world
  let
    newW = w { currentRegionIndex = Nothing }
  set world newW
  selectId  "statusRegion" & empty
  setupPuzzleTable world
There is a div in the html file for the current status. This is handy for the user so he can see what is going on, and handy for me to make sure I haven't gone off the rails. rangeStatus display the range of numbers that make up the puzzle, usually from 1 to n. regionStatus displays how many regions have been defined, and how many squares are left to be added to the regions.
«client status»
------------------------------ Status ------------------------------

rangeStatus :: W -> Fay ()
rangeStatus w = do
  let
    msg = Fay.JQUtils.unwords
      [ "The range runs from" 
       , showInt (head . puzzleElementRange . board $ w)
       , "to"
       ,  showInt (last . puzzleElementRange . board $ w) ]
  setStatus "statusRange" msg

regionStatus :: W -> Fay ()
regionStatus w = do
  let
    d = numberOfRegionsDefined w
    g = numberOfSquaresToGo w
    dText = englishInt d "region"
    gText = englishInt g "square"
    allText = dText <> " defined, " <> gText <> " remaining."
  setStatus "statusRegion" allText
These functions setup the various widgets displayed on the page, and associate them with their handlers. change is a jQuery onchange callback, which is called whenever the status of the widget is changed. There are two little gotchas that are not obvious in this code. One was that to make an option be selected you have to set the selected atrribute to the value "selected." The other is that in the html file, the span associated with the puzzle table must have the attribute contenteditable set to "true."
«client setup»
------------------------------ Setup ------------------------------

setupPuzzleMode :: World -> Fay ()
setupPuzzleMode world = do
  editing <- select ("[name=editing]" :: Text)
  change (handlePuzzleMode world) editing

setupSize :: World -> [Int] -> Fay ()
setupSize world l = do
  selectId "inputShow "  & click (handleInputShow world)
  selectId "inputEvents" & click (handleInputEvents world)
  selectId "inputShared" & click (handleInputShared world)
  size <- selectId "size"
  change (handleSize world) size
  forM_ l $ \i -> do
    option <- select ("<option value=''></option>" :: Text) & setVal (showInt i)
    appendTo size option
    setText (showInt i) option

ints :: [Int]
ints = [0..]

setupRange :: World -> Int -> Fay ()
setupRange world n = do
  fromSelect <- selectId "from"
  change (handleFrom world) fromSelect
  toSelect <- selectId "to"
  change (handleTo world) toSelect
  add fromSelect toSelect & empty
    -- Note: JQuery is not an instance of Eq
    -- thus the need for the zip junk and the wierd case statement
  forM_ (zip ints [fromSelect, toSelect]) $ \(j,div) ->
    forM_ [-n .. n] $ \i -> do
       option <- select ("<option value=''></option>" :: Text) 
       setVal (showInt i) option
       let
         selected :: JQuery -> Fay JQuery
         selected = case j of
           0 -> if i == 1 then setAttr "selected" "selected" else return
           1 -> if i == n then setAttr "selected" "selected" else return
       s <- selected option
       appendTo div s
       setText (showInt i) s

setupOperators :: World -> Fay ()
setupOperators world = do
  operator <- selectId "operator" & empty
  forM_ valueToOperationTextMap $ \vt -> do
    option <- select ("<option></option>" :: Text) & appendTo operator
    setVal (fst vt) option
    setHtml (snd vt) option

setupPuzzleTable :: World -> Fay ()
setupPuzzleTable world = do
  w <- get world
  let n =  puzzleSide . board $ w
  table <- select ("<table border='1' style='float:left'></table>" :: Text)
  p <- selectId "puzzleTable" 
  empty p & appendJQuery table 
  whenTablet p hvoid (keyup (checkForEnter world))
  let
    rowColumn :: [[[Int]]]
    rowColumn = [ [ [i,j] | j<-[1..n] ] | i<-[1..n] ]
  forM_ rowColumn $ \row -> do
    tr <- select ("<tr></tr>" :: Text) & appendTo table
    forM_ row $ \ij -> do
      let c = ((ij!!0) , (ij!!1))
      td <- select ("<td></td>" :: Text) & appendTo tr
      let button = Fay.JQUtils.unwords [
                  "<input type='button'"
                , "id='" <> idFromCoord c <> "'"
                , "class='tableCell'>" ]
      selectText button & appendTo td
                    & click (handleSquareEvent world)
  setupPuzzleMode world
  updateBoard w
Here all the various callback handlers are defined. worldChangeHandler takes one of two actions, depending upon whether regions exist or not. This is used when the user decides to change a parameter of the puzzle that would affect the currently existing regions. An alert window is presented to give the user a chance to change his mind. If he goes ahead, all existing regions are reset. backoutWithWorld resets the value of the widget associated with an event to a string that is computed based on the current state of the world.
«client handlers 1»
------------------------------ Handlers ------------------------------

worldChangeHandler :: World -> Event -> EventHandler -> EventHandler -> Fay ()
worldChangeHandler world e h1 h2 = do
  ok <- doRegionsExist world
  handler <- if ok then do
    msg <- fmap makeSafe $ selectId "worldChange" & getHtml
    ok <- windowConfirm msg
    return $ if ok then h1 else h2
    else return h1
  handler world e

backoutWithWorld :: (W -> Text) -> EventHandler  
backoutWithWorld f world e = do
  w <- get world
  let v = f w
  t <- target e
  select t & setVal v
  return ()
handleSize takes care of two cases. changeSize is called the first time the size is defined and resetSize is called when the size is changed after some regions have already been defined. Once the size is specified, we are ready to let the user define the range of values to be allowed in the puzzle, so we populate and display the "from" and "to" range select widgets based on the size. At this point we can expose the range widget, the puzzleType widget, and the puzzleTable table. The operation and value remain hidden until the puzzleType is known, since if the puzzleType is Killer thexn there is no need for the operation select widget, as it is always Plus. Also the instructions div set to explain to the user what to do next. The way this works is to copy the contents of a hidden div in the html file to the instructions div. The
doParm function handles updating the state of world based on a parser, an updater, and an event.
«client handlers 2»
handleSize :: EventHandler
handleSize world e = worldChangeHandler world e changeSize resetSize 
  where
    changeSize world e = do
      reinitialize <- doRegionsExist world
      when reinitialize  (resetRegions world >> initialize world)
      w <- doParam world readInt updateAll e
      let
        pSize = puzzleSide . board $ w
        n = showInt pSize
        msg = "The size of the puzzle is " <> n <> " by " <>  n
      setStatus "statusSize" msg
      setupRange world pSize
      puzzleType <- selectId "puzzleType"
      change (handlePuzzleType world) puzzleType
      setExplain "explainRange"
      rangeStatus w
      exposeIds ["range"]
      setupPuzzleTable world
      selectId "size" & setProp "disabled" "disabled" & hvoid
    resetSize = backoutWithWorld (showInt . puzzleSide . board)
handleFrom and handleTo are pretty straightforward. handlePuzzleType is again more complicated because if it is called after regions have been defined, we must warn the user of the consequences of changing the type, namely that his regions will be lost. At this point we set up the Operation widget and if the puzzleType is Killer, we hide it, otherwise we expose it. We also set up the instructions div to tell the user what to do next.
«client handlers 3»
handleFrom :: EventHandler
handleFrom world e = do
  doParam world readInt updateLow e
  get world >>= rangeStatus

handleTo :: EventHandler
handleTo world e = do
  doParam world readInt updateHigh e
  get world >>= rangeStatus

handlePuzzleType :: EventHandler
handlePuzzleType world e =
  worldChangeHandler world e changePuzzleType resetPuzzleType 
  where
    changePuzzleType world e = do
      reinitialize <- doRegionsExist world
      when reinitialize (resetRegions world)
      let parsePuzzle x = maybe (tError ("handlePuzzleType: No such puzzle type " <> x)) id (lookup x puzzleTypeMap)
      w <- doParam world parsePuzzle updatePuzzleType e
      let bd = board w
      logEvent world (P (puzzleType bd) (puzzleSide bd)(puzzleElementRange bd) )
      setupOperators world
      if (puzzleType . board $ w) == Killer then do
        hideIds ["operator"]
        setExplain "explainKillerCreateRegion"
        else do
          exposeIds ["operator"]
          setExplain "explainCreateRegion"
      selectId "finishRegion"  & click (handleFinishRegion world)
      exposeIds ["resultSpan" , "finish", "editingSpan" ]
      rangeStatus w
    toPuzzleText x = maybe "single" id (lookup x (reverseMap puzzleTypeMap))
    resetPuzzleType = backoutWithWorld (toPuzzleText . puzzleType . board)
To make recovering from mistakes easier, I've added the some editing modes. The default mode is to toggle a square's membership in the current region, adding it if it is not a member, and removing it if it is a member. Another mode is delete mode, which simply removes cells from their region. Another mode is to create a new region or make an existing region the current region when you click on a square. Finally in case you discover that you put the wrong operator or value on a region, there is a mode that allows you to change that too. That pretty much covers all the ways you can enter a puzzle and then discover that you made a mistake, and fix it easily.

The modes I define are:

handlePuzzleMode is the registered event hander when the user clicks on one of the radio buttons to change the current mode. It grabs the new mode and stores it in the world global. If the new mode is ModeSelectRegion we finish the current region.

«client handlers 4»
handlePuzzleMode :: EventHandler
handlePuzzleMode world e = do
  setError ""
  stopImmediatePropagation e
  w <- get world
  modeName <- fmap makeSafe $ target e & select & getVal
  let 
    newEditState = decodePuzzleMode modeName
    newW = w { editing = newEditState }
  set world newW
  logEvent world $ M newEditState
  if newEditState == ModeSelectRegion
    then handleFinishRegion world undefined else return ()
handleSquareEvent is called whenever a square is clicked. It just get the co-ordinates of the square and calls handleCell to dispatch on the current mode
«client handlers 5»
handleSquareEvent :: EventHandler
handleSquareEvent world e = do
  tableCell <- target e & select
  coordId <- fmap makeSafe $ getAttr "id" tableCell
  let
    thisCoord = coordFromId coordId
  handleCell world thisCoord 

handleCell :: CellHandler
handleCell world thisCoord = do
  w <- get world
  case editing w of
    ModeToggleCell   -> handleModeToggleCell world thisCoord
    ModeRemoveCell   -> handleModeRemoveCell world thisCoord
    ModeSelectRegion -> handleModeSelectRegion world thisCoord
    ModeChangeValue  -> handleModeChangeValue world thisCoord
  w <- get world
  updateBoard w
handleModeChangeValue is called when you want to change the operator and/or the value for a particular region. I try to cause the least surprise, so if the user is in this mode and clicks on a cell that is not in an existing region, we just toggle it into the current region. If the cell is in an existing region, we make sure the operator is valid and if it is, update the world global with changeValueEffect to reflect the change.

This might be a good time to mention logging. Every event the user generates is logged and displayed to the right of the board. When problems occur, they can copy and past the event log and send it to me via email. I can then replay the events on my machine and where something when wrong.

«client handlers 6»
handleModeChangeValue :: CellHandler
handleModeChangeValue world thisCoord = do
  w <- get world
  let
    maybeExistingRegion = lookupCellInRegions w thisCoord 
    w1 = w {   currentRegionIndex = maybeExistingRegion
               , editing = ModeToggleCell }
  case maybeExistingRegion of
    Nothing -> do                   -- This cell was not in a region,
                                    -- so just proceed to toggle it into
                                    -- a new region
      set world w1
      logEvent world $ R maybeExistingRegion
      logEvent world $ M ModeToggleCell
      handleCell world thisCoord
    Just existingRegionIndex ->  do -- This cell is in an existing region
                                    -- and we want to change its operator
                                    -- and value, so make sure a valid
                                    -- (not null) operator and value are
                                    -- entered
      valid <- setupNewRegion w
      case valid of
        Nothing -> do               -- The operator or value wasn't valid
                                    -- so change nothing and keep the world
                                    -- as it was
          return ()
        Just r -> do                -- The operator and value were valid,
                                    -- and there exists a region that contains
                                    -- this coord, so change this regions
                                    -- operator and value to the new ones
          let
            newW = changeValueEffect w1 (regionOperation r) (regionResult r)
          set world newW
          logEvent world $ M ModeToggleCell
          logEvent world $ R maybeExistingRegion
          logEvent world $ V (regionOperation r) (regionResult r)
          setError ""

changeValueEffect :: W -> Operation -> Value -> W
changeValueEffect w o v =
  let
    rExisting = currentRegion w
    newR = rExisting {   regionResult = v
                       , regionOperation = o }
    newW = updateCurrentRegion w newR
  in newW  
handleModeSelectRegion is the handler called when a cell is clicked in the ModeSelectRegion mode. If the cell is in an existing region, it is made current and blinked. If the cell isn't in an existing region, we try to create a new region, which will probably fail unless the user was prescient enough to have selected a new operator and value. This mode is only enabled for one click, after which the mode returns to ModeToggleCell.
«client handlers 7»
handleModeSelectRegion :: CellHandler
handleModeSelectRegion world thisCoord = do
  w <- get world
  -- tPutStrLn $ "In handleModeSelectRegion with " <> (tShow thisCoord)
  let newW = selectRegionEffect w thisCoord
  set world newW
  logCoordEvent world thisCoord
  -- tPutStrLn $ "maybeExistingRegion is " <> (tShow maybeExistingRegion)
  maybe (handleCell world thisCoord)
        (const (selectCell thisCoord & blink "redBackground"))
        (currentRegionIndex newW)

blink :: Text -> JQuery -> Fay ()
blink = ffi "%2['blink'](%1)"

selectRegionEffect w c =
  w {   currentRegionIndex = maybeExistingRegion
      , editing = ModeToggleCell }
  where
    maybeExistingRegion = lookupCellInRegions w c 
handleModeRemoveCell is the handler called when a cell is clicked in the ModeRemoveCell mode. If no regions exist, the user gets an error message, otherwise the cell is removed from its region. You will notice a worrying head . puzzleConstraints in the definition of removeFromBoard. Recall that puzzleConstraints is never empty. It has one element is the PuzzleType is Single or Killer, and two elements if the PuzzleType is Double. Removing a cell always makes no region current.
«client handlers 8»
handleModeRemoveCell :: CellHandler
handleModeRemoveCell world thisCoord = do
  thereAreRegions <- doRegionsExist world
  if thereAreRegions then do
    w <- get world
    let newW = removeCellEffect w thisCoord
    set world newW
    logCoordEvent world thisCoord
    regionStatus newW
    else do
      setError "There are no more regions to remove squares from"

removeCellEffect :: W -> Coord -> W
removeCellEffect w c = removeEmptyRegions $ 
  w {  board = newBoard
     , currentRegionIndex = Nothing}
  where  newBoard = removeFromBoard c (board w)

removeFromBoard :: Coord -> Board -> Board
removeFromBoard c bd = bd { puzzleConstraints = newConstraints bd : tail (puzzleConstraints bd) }
  where
    newConstraints :: Board -> Constraints
    newConstraints = removeFromConstraint c . head . puzzleConstraints 
    removeFromConstraint :: Coord -> Constraints -> Constraints
    removeFromConstraint c1 = Constraints . map (removeFromRegion c1) . regions

removeFromRegion :: Coord -> Region -> Region
removeFromRegion c g = g { regionCoords = filter (/= c) (regionCoords g) }
setupNewRegion is called whenever we want to create a new region. It checks that the prerequisites already exist, namely that the puzzle type, region operator, and region value are defined. error message is displayed if any of these are missing. If all is well, a new Region is returned.
«client handlers 9»
setupNewRegion :: W -> Fay (Maybe Region)
setupNewRegion w = do
  if pType == NullP then setError "You must select a puzzle type!" >> return Nothing
    else do
      operator <- if (puzzleType . board $ w ) == Killer
                  then return "Plus"
                  else fmap makeSafe $ selectId "operator" & getVal
      let op = lookup operator valueToOperationMap
      result <- fmap makeSafe $ selectId "result" & getVal
      setError ""
      maybe (setError "You must select an operator!" >> return Nothing)
            (handleOperator result)
            op
  where
    pType = puzzleType . board $ w
    handleOperator result theOperator = do
      setError ""
      if result == ""
         then setError "You must select a value!" >> return Nothing
         else do
          return $ Just (Region (readInt result) theOperator [])
handleModeToggleCell is called when a square is clicked and we are in ModeToggleCell mode. If we are in a new region, we make sure its prerequisites are valid, and then toggle this cell into or out of the current region. We are slightly smart about the operator, namely if we know in advance how many cells are needed by a specific operator, we immediately finish that region. For example, if the operator is Id, which means that the specified cell must have this value, then we know the region can only be one cell large. This logic is handled in the runToggle function below. We also check to see of all of the cells have been used, and if so finish the current region.
«client handlers 10»
handleModeToggleCell :: CellHandler
handleModeToggleCell world thisCoord = do
  {- When I finally tried this on my ipad, I discovered that every time
     I touched a square in the puzzle, the keyboard would pop up.  I 
     tried not attaching the keyup handler to the table, but that had 
     no effect, so after searching around discovered I could blur the
     active element and that would push the keyboard back down into
     its place. 
  -}
  w <- get world
  whenTablet () (const hideIpadKeyboard) hvoid
  if isNewRegion w then do
    let cellIsAlreadyInARegion = maybe False (const True) (lookupCellInRegions w thisCoord)
    if cellIsAlreadyInARegion
      then do
        setError "This cell is in a finished region, and cannot be toggled"
        return ()
      else do
        valid <- setupNewRegion w
        case valid of
          Nothing -> updateBoard w
          Just r -> do
            logEvent world $ N (cRow thisCoord) (cColumn thisCoord) (regionOperation r) (regionResult r)
            runToggle world thisCoord r
            setError ""
        else do
          logCoordEvent world thisCoord
          runToggle world thisCoord (currentRegion w)

runToggle :: World -> Coord -> Region -> Fay ()
runToggle world thisCoord r = do
  w <- get world
  let
    w1 = toggleCellEffect w thisCoord r
    theOperator = regionOperation r
  set world w1
  case length (regionCoords (currentRegion w1)) of
    1 -> when (theOperator ==  Id) $ handleFinishRegion world undefined
    2 -> when (theOperator == Mod) $ handleFinishRegion world undefined
    otherwise -> return ()
  w3 <- get world  
  regionStatus w3
  updateBoard w3
  let squaresLeft = numberOfSquaresToGo w3
  when (squaresLeft == 0) $ handleFinishRegion world undefined
  return ()

toggleCellEffect :: W -> Coord -> Region -> W
toggleCellEffect w c r = updateCurrentRegion w (toggleMembership c r)

toggleMembership :: Coord -> Region -> Region
toggleMembership c g =
  let
    isInRegion = c `elem` regionCoords g
    regionWouldBeEmpty =  isInRegion && length (regionCoords g) == 1
    result = if regionWouldBeEmpty then g
      else
        if isInRegion
    then removeFromRegion c g
          else g { regionCoords = regionCoords g ++ [c]}
  in result
handleFinishRegion as you might guess, we get here when a region has been finished. We do nothing if there is no current region, otherwise we reset the operator and result fields of the form, set the current region to Nothing, redisplay the board and check if all of the squares have been used. If so we call handleAllCellsDefined which will might send the board to server. handleAllCellsDefined is called whenever there are no more squares left to define. That does not necessarily mean we are completely finished with the puzzle. Some calcudoku puzzles are Doubles, meaning that the same solution must exist for two different puzzles. If the puzzle type is Double and we have only defined one board, we need to go and define the other board. This involves creating a new board with the head of puzzleConstraints null, and the tail (second element) of puzzleConstraints equal to the just defined set of constraints for the first half of the double puzzle. If the puzzle type isn't Double, or we have finished defining the second half of a Double puzzle, we call postToSnap to send the world to the server. Once the puzzle is defined completely, we set the answer region to a message that the answer should appear here shortly. This is in case the puzzle takes too long to solve. We then run an ajax call to the server with the Board as the posted data. If all goes well, the server responds with a solution which is put into the answer div. The answer returned should be plain text that is stuffed into an pre element. Just for fun, we also display the data sent to the server in the post request in the puzzleData div. I found this useful for debugging, and perhaps if the user is a programmer it will help them understand what is going on.
«client finishRegion»
handleFinishRegion :: EventHandler
handleFinishRegion world _ = do
  w1 <- get world
  when (not $ isNewRegion w1) $ do
    let g = currentRegion w1
    logEvent world (V (regionOperation g) (regionResult g) )
    logEvent world (R Nothing)
    selectId "operator" & setVal ""
    selectId "result" & setVal ""
    w2 <- get world
    let newW = w2 { currentRegionIndex = Nothing }
    set world newW
    updateBoard newW
    let squaresLeft = numberOfSquaresToGo newW
    regionStatus newW
    if squaresLeft /= 0 then return () else handleAllCellsDefined world
    -- tPutStrln $ "In handleFinishRegion2 with " <> (tShow newW)

handleAllCellsDefined :: World -> Fay ()
handleAllCellsDefined world = do
  w <- get world
  if (puzzleType . board $ w) == Double then
     case length . puzzleConstraints . board $ w of
       1 -> do
         let
           b = board w
           newB = b { puzzleConstraints = Constraints [] : puzzleConstraints b}
           newW = w { board = newB }
         setExplain "secondPartOfDouble"
         hideIds ["size", "puzzleType", "range" ]
         set world newW
         setupPuzzleTable world
       2 ->  setExplain "doubleFinished" >> postToSnap w
       _ -> tError "there should only be 1 or 2 puzzle constraints"
     else postToSnap w
postToSnap is called when we have finished defining the puzzle. It tells the user to be patient, and cleans up any empty regions that may have been created. It sets the puzzleData region on the web page to the data that is about to be sent to the server, creates a new Shared data type, and packs it all of to send to the server. The server should reply with a simple html message, which will be displayed in the answer div once it is received.
«client postToSnap»
postToSnap :: W -> Fay ()
postToSnap w = do
  let bd = board w
  setExplain "puzzleFinished"
  -- tPutStrLn $ "Board: is done" <> showWorld w
  let
    cleanConstraints = map removeEmptyRegions (puzzleConstraints bd)
    removeEmptyRegions c = Constraints $
                          filter (\g -> regionOperation g /= Empty) (regions c)
    newB = bd { puzzleConstraints = cleanConstraints }
    shared = defaultShared
      {  sharedBoard = newB
       , sharedEvents = (reverse $ cevents w)
       , sharedPosted = False }
    textToPost = "Encode:" <> (encodeShared shared)
  selectId "puzzleData" & empty & hvoid
  tellUser textToPost
  jPostBoard "fayParse" textToPost setAnswer

tellUser :: Text -> Fay ()
tellUser sharedText = do
  let
    formatted = T.unlines . map T.pack . breakNear 80 ',' $ (T.unpack sharedText)
    lengthOfShared = T.length sharedText
    t1 = "The answer should appear here shortly"
    t2 = "<hr/><br/>This is the data that is being sent to the server, \
         \if you have problems, please copy and paste it in a message to Henry.<br/>"
    t3 = "<br/>Post length is: " <> showInt lengthOfShared <> " bytes</p>"
    t4 = T.unlines [t2,"<pre>",formatted,"</pre>",t3]
  selectId "answer" & empty & setHtml t1
  selectId "after-answer" & empty & setHtml t4
  return ()

setAnswer :: Text -> Fay ()
setAnswer s = do
  -- tPutStrLn "entered setAnswer"
  selectId "answer" & empty & Fay.SafeJQuery.append s & hvoid
logEvent and logCoordEvent are called throughout to log the event so that it can be replayed.
«client logging»
logCoordEvent :: World -> Coord -> Fay ()
logCoordEvent world thisCoord =  logEvent world (L (cRow thisCoord) (cColumn thisCoord) )

logEvent :: World -> CEvent -> Fay ()
logEvent world e = do
  puzzleEvents <- selectId "puzzleEvents"
  appendText (" " <> encodeCEvent e ) puzzleEvents & hvoid
  w <- get world
  let newW = w {cevents = e : cevents w}
  set world newW
  -- tPutStrLn $ "logEvent Event" <> showCEvent e 
  -- tPutStrLn $ "logEvent World" <> showWorld newW
checkForEnter is an event handler that checks to see if the enter key has been pressed. Pressing the enter key means that the current region being defined is finished. It is easier to do this rather than clicking on the "finish region" button.
«client checkForEnter»
checkForEnter :: EventHandler
checkForEnter world e = do
  code <- which e
  -- tPutStrLn $ "checkForEnter: " <> (showInt code)
  when (code == 13) $ handleFinishRegion world e
simulateEvents unravels a bunch of space delimited events that were recorded while the user was doing his input. These events are displayed as the user enters them to the right of the puzzle board. If something goes wrong, the user can easily copy and paste these events and send them to me. I can run them through this function and recreate the board. It has come in handy several times now.

runEvents calls simulateEvents to create a new world global that gets posted to the server.

handleInputEvents is only available in debug mode. It reads worldEvents textbox and runs the events

«client events»
simulateEvent :: CEvent -> W -> W
simulateEvent cev w = 
  let
    bd = board w
    result = case cev of
      P x1 x2 x3 -> w { board =
                          bd {puzzleType = x1,
                              puzzleSide = x2,
                              puzzleElementRange = x3}}
      L x1 x2 ->
        let
          r = currentRegion w
          c = mkC x1 x2
          mode = editing w
          newW = case mode of
            ModeToggleCell   -> toggleCellEffect w c r
            ModeRemoveCell   -> removeCellEffect w c
            ModeSelectRegion -> selectRegionEffect w c
            ModeChangeValue  -> w
        in newW
      M x1 -> w { editing = x1 }
      R x1 -> w {currentRegionIndex = x1 }
      V x1 x2 -> changeValueEffect w x1 x2
      N x1 x2 x3 x4 -> toggleCellEffect w (mkC x1 x2) (Region x4 x3 [])
      otherwise -> tError $ "simulate events error " <> tShow otherwise
  in result

readEvents :: Text -> Fay [CEvent]
readEvents textEvents = do
  selectId "debug-show" & setHtml textEvents
  let eventList = decodeCEvents textEvents
  return eventList

runEvents :: Text -> Fay ()
runEvents textEvents = do
  selectId "debug-show" & setHtml textEvents
  events <- readEvents textEvents
  finalW <- foldM simulate1 defaultW events
  newWorld <- newRef finalW 
  setupPuzzleTable  newWorld
  let squaresLeft = numberOfSquaresToGo finalW
  if squaresLeft /= 0 then return () else postToSnap finalW
  where
    simulate1 a b = do
      -- tPutStrLn (showCEvent b)
      return $ simulateEvent b a

handleInputEvents :: EventHandler
handleInputEvents _ _ = do
  inputEvents <- fmap makeSafe $ selectId "inputEvents" & prev & getVal
  runEvents inputEvents
Similar to handleInputEvents, handleInputShared runs the board defined by the global Shared. handleInputShow expects to receive a Shared that was written by haskell's show instance, suitable for a read. Why do I need two different ways to run the solver? Well, if instead of entering the puzzle via fay, the user uses this solver to grab and parse a calcudoku puzzle from calcudoku.org, then there won't be any events defined. The server will parse the puzzle it finds at the specified url, create a Shared, and send it off to the solver. I get a copy of the Shared data if something goes wrong via email.
«client handleInputShared»
handleInputShared :: EventHandler
handleInputShared _ _ = do
  sharedText <- fmap (deblank . makeSafe) $ selectId "inputShared" & prev & getVal
  let textToPost = "Encode:" <> sharedText
  tellUser textToPost
  jPostBoard "fayParse" textToPost setAnswer

handleInputShow :: EventHandler
handleInputShow _ _ = do
  tPutStrLn "handleInputShow"
  showText <- fmap makeSafe $ selectId "inputShow" & prev & getVal
  let textToPost = "Show:" <> showText
  tellUser textToPost
  jPostBoard "fayParse" textToPost setAnswer
lookupCellInRegions looks to see if the cell is in an existing region. If so, it returns Just the index of the region in the list of current constraints. If not, it returns Nothing.
«client lookupCellInRegions»
lookupCellInRegions :: W -> Coord -> Maybe Int
lookupCellInRegions w c =
  let
    justRegions = regions . currentConstraints $ w
    indexedRegions = zip justRegions [0..]
    go [] = Nothing
    go (r1:rs) = if c `elem` (regionCoords . fst $ r1) 
                   then Just (snd r1) else go rs
  in go indexedRegions
As you might guess, we get here when a region has been finished. At this point we have to add the current region to the list of Constraints, and reset the current region to null. We also check to see if there are any more squares left to be defined. If not we need to do more finishing.

Fay version 18 and beyond

When Fay version 18 came out, all strings disappeared and were changed to Text. At this point I decided to move the pieces of Fay that I use often into their own module, which I import into different projects. The result is the code below, some of it shamelessly stolen from others. Since the JQuery interface always uses the matched set as the last arguement, and usually returns the matched set, the use of the infix & make writing some of the functions shorter and more expressive.
«fayJQUtils bind»
(&) :: Fay a -> (a -> Fay b) -> Fay b
x & y = x >>= y
infixl 1 &
Next we include some DOM manipulations that we have to do frequently. selectId happens so often, that I got tired of typing the "#" sign. Hopefully they are pretty much self explanatory.
«fayJQUtils dom»
selectId :: Text -> Fay JQuery
selectId = ffi "jQuery('#'+%1)"

selectText :: Text -> Fay JQuery
selectText = ffi "window['jQuery'](%1)"

appendText :: Text -> JQuery -> Fay JQuery
appendText = ffi "%2['append'](%1)"

prependText :: Text -> JQuery -> Fay JQuery
prependText = ffi "%2['prepend'](%1)"

exposeIds :: [Text] -> Fay ()
exposeIds l =  forM_ l $ \i -> selectId i & removeClass "hidden"

hideIds :: [Text] -> Fay ()
hideIds l =  forM_ l $ \i -> selectId i & addClass "hidden"

enable ::  JQuery -> Fay JQuery
enable = ffi "%1['prop'](\"disabled\",false)"

disable ::  JQuery -> Fay JQuery
disable = ffi "%1['prop'](\"disabled\",true)"

checked :: JQuery -> Fay JQuery
checked  = ffi "%1['prop'](\"checked\",true)"

unchecked :: JQuery -> Fay JQuery
unchecked  = ffi "%1['prop'](\"checked\",false)"

scrollOneLine :: JQuery -> Fay ()
scrollOneLine = ffi "%1['scroll']()"

jsBlur :: JQuery -> Fay JQuery
jsBlur = ffi "%1['blur']()"
Here are some text and show functions that I need all the time, and for some reason didn't work for me with pack . show when I tried them. Again, hopefully they are pretty much self explanatory.
«fayJQUtils show and text»
trim :: Text -> Text
trim = ffi "jQuery['trim'](%1)"

englishInt :: Int -> Text -> Text
englishInt n t = 
  case n of
      0 -> "No " <> t <> "s"
      1 -> "1 " <> t
      x -> showInt x <> " " <> t <> "s"

showJQuery :: JQuery -> Text
showJQuery = ffi "JSON.stringify(%1)"

showElement :: Element -> Text
showElement = ffi "JSON.stringify(%1)"

showEvent :: Event -> Text
showEvent = ffi "JSON.stringify(%1)"

showList :: [Int] -> Text
showList = ffi "JSON.stringify(%1)"

showArbitrary :: a -> Text
showArbitrary = ffi "JSON.stringify(%1)"

doubleQuote :: Text -> Text
doubleQuote s = "\"" <> s <> "\""

deblank :: Text -> Text
deblank = ffi "%1.replace(/\\s+/g,'')"
I wish these had been included in the Prelude defined by fay-base.
«fayJQUtils missing from the prelude»
split :: Text -> Text -> [Text]
split = ffi "%2.split(%1)"

words :: Text -> [Text]
words = ffi "%1.split(\" \")"

unwords :: [Text] -> Text
unwords = ffi "%1.join(\" \")"

readBool :: Text -> Bool
readBool x = if x == "True" then True else False
Here are some parsers that didn't work as read . unpack, so I added them here.
«fayJQUtils parsers»
readInt :: Text -> Int
readInt = ffi "parseInt(%1)"

readIntList :: Text -> [Int]
readIntList = ffi "JSON.parse(%1)"

readDouble :: Int -> Text -> Double
readDouble = ffi "parseFloat(%2,%1) || 0"
Some miscellaneous functions that come in handy.
«fayJQUtils other»

exists :: JQuery -> Bool
exists = ffi "%1.length > 0"

alert :: Text -> Fay ()
alert = ffi "alert(%1)"

jPost :: Text -> Automatic f -> (Automatic g -> Fay ()) -> Fay ()
jPost = ffi "jQuery.ajax(%1, { data: JSON.stringify(%2), type: 'POST', processData: false, contentType: 'text/json', success: %3 })"

windowUrl :: Fay Text
windowUrl = ffi "window.location.href"

windowUserAgent :: Fay Text
windowUserAgent = ffi "navigator.userAgent"

hideIpadKeyboard :: Fay ()
hideIpadKeyboard = ffi "document.activeElement.blur()"

isPrefixOf :: Text -> Text -> Bool
isPrefixOf  = ffi "%2.indexOf(%1) == 0"

isInfixOf :: Text -> Text -> Bool
isInfixOf = ffi "%2.indexOf(%1) >= 0"
These guys want a string in Haskell, but Fay wants Text.
«fayJQUtils text versions»
tError :: Text -> a
tError = error . unpack

tPutStrLn :: Text -> Fay ()
tPutStrLn = Data.Text.putStrLn

tShow :: Show a => a -> Text
tShow = pack . show

tPrint :: Show a => a -> Fay ()
tPrint = tPutStrLn . tShow

serialize :: JQuery -> Fay Text
serialize = ffi "%1['serialize']()"

consoleLog :: JQuery -> Fay ()
consoleLog = ffi "console['log'](%1)"

safeTail :: [a] -> [a]
safeTail l = if Prelude.null l then l else Prelude.tail l
I implement some Read/Show instances with lookup from the Prelude. Also doParam is a helper that is a little complicated. It take a reference to a variable, usually the global state world, a parser function that converts Text to an internal type, and updating function that modifies the internal structure of the world, and a Javascript event. It decodes the event, and updates the world to the new value. It returns the new world, wrapped in the Fay monad.
«fayJQUtils read show with maps»
doParam :: Ref b -> (Text -> a) -> (b -> a -> b) -> Event -> Fay b
doParam world parser updateF e = do
  t <- target e
  sval <- fmap makeSafe $ select t & getVal 
  w <- get world
  let newW = updateF w (parser sval)
  set world newW
  return newW

redirect :: Text -> Fay ()
redirect = ffi "window.location.href = %1"

debug :: Text -> Fay ()
-- debug _ = return ()
debug = Data.Text.putStrLn

onEvent :: EventType -> (Event -> Fay ()) -> Fay ()
onEvent = ffi "jQuery(document).bind(%1,%2)"

isDebug :: Fay Bool
isDebug = do
  url <- windowUrl
  let
    debug = unpack "debug"
    queryParms = dropWhile (/= '?') (unpack url)
    debugging = Prelude.not (Prelude.null queryParms) && debug == (Prelude.take (Prelude.length debug) . Prelude.tail $ queryParms)
  return debugging

cloneId :: Text -> Fay JQuery
cloneId idText = do
  selectId idText & clone WithoutDataAndEvents
    & removeAttr "id"
    & removeClass "hidden"

fmap :: (a -> b) -> Fay a -> Fay b
fmap f a = do
  a1 <- a
  return (f a1)
I need to guard against malicious input, So I downloaded the Dom Purify library to help eliminate cross site scripting attacks.
«fayJQUtils cross site scripting»
purifyConfig :: Fay ()
purifyConfig = ffi "DOMPurify.setConfig({SAFE_FOR_JQUERY: true})"

Conclusion

Well, that is all for now. Next I'll try to document the Solver, for your amusement and edification. I hope you've enjoyed this tour through a sample Fay application. Thank you again, Chris and Adam for allowing me to escape the Javascript jail and enter the Haskell heaven.

You can download this code from here.

Quote of the day:
It is now quite lawful for a Catholic woman to avoid pregnancy by a resort to mathematics, though she is still forbidden to resort to physics or chemistry.
H. L. Mencken

Sitemap
Go up to Haskell Go up to Home Page of Nadine Loves Henry
Go back to How to use Data.Lens Continue with A Medium Sized Snaplet Example