Implemented main Gpu functions, read/write byte and vram write

module Gpu
  ( resetScreen
  , gpuStep
  , gpuRd8
  , gpuWr8
  , wrVRam
  , cleanGpu
  , module Graphics.Canvas
  ) where

import Prelude
import Control.Bind
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Data.Int
import Data.Int.Bits
import Data.Foldable
import Data.Array as A
import Data.Sequence as S
import Data.Maybe
import Graphics.Canvas

import Types
import Utils
import Debug

foreign import setScreen :: forall e. Array I8 -> Context2D
                       -> Eff (canvas :: Canvas | e) Unit

modeDuration :: GpuMode -> Int
modeDuration = case _ of
  HBlank -> 51
  VBlank -> 114
  VramScan -> 43
  OamScan -> 20

cleanTile :: Tile
cleanTile = Tile $ S.fromFoldable $ A.replicate 64 0

getCanvas :: forall e. Eff (canvas :: Canvas | e) Context2D
getCanvas = do
  Just canvasElem <- getCanvasElementById "screen"
  getContext2D canvasElem

resetScreen :: forall e. Eff (canvas :: Canvas | e) Unit
resetScreen = setScreen arr =<< getCanvas
 where
  arr = A.replicate (160*144*4) 255

cleanGpu :: Gpu
cleanGpu =
  { mTimer : 0
  , dispOn : false
  , bgOn : false
  , bgMap1 : false
  , bgSet1 : false
  , scrBuf : S.empty
  , currLine : 0
  , currPos : 0
  , yScroll : 0
  , xScroll : 0
  , palette : S.fromFoldable $ A.replicate 4 cleanColor
  , mode : OamScan
  , tiles : S.fromFoldable $ A.replicate 384 cleanTile
  , regs : S.fromFoldable $ A.replicate 0x40 0
  , vram : S.fromFoldable $ A.replicate 8192 0
  , oam  : S.fromFoldable $ A.replicate 160 0
  }

cleanColor :: Color
cleanColor = {a:0,r:0,g:0,b:0}

getCtrlFlags :: Gpu -> I8
getCtrlFlags gpu =  cf gpu.bgOn   0x01
                .|. cf gpu.bgMap1 0x08
                .|. cf gpu.bgSet1 0x10
                .|. cf gpu.dispOn 0x80
 where cf bool flag = if bool then flag else 0x00

gpuStep :: forall e. I8 -> Gpu -> Eff (canvas :: Canvas | e) Gpu
gpuStep mReg gpu@{mTimer,mode,currLine,currPos,scrBuf} = gpu'
 where
  mTimer' = mTimer + mReg

  gpu' = if mTimer' < modeDuration mode
    then return gpu { mTimer = mTimer' }
    else case mode of
      HBlank -> do --TODO set True least significant interrupt flags bit
        when ((trs "currLine" currLine) == pixHeight - 1)
          $ setScreen (seqToArray scrBuf) =<< getCanvas
        return gpu { mTimer = 0
                   , scrBuf = S.empty :: S.Seq I8 --psc forces me here
                   , currLine = currLine + 1
                   , currPos = currPos + bytesWidth
                   , mode = if currLine == pixHeight - 1 then VBlank
                                                         else OamScan
                   }
      VBlank -> do
        let setOnLastLine =
              if currLine == pixHeight + 10 - 1
                -- 10 increments after last line of 143
                then _ { mTimer = 0
                       , currLine = 0
                       , currPos = 0
                       , mode = OamScan
                       }
                else id
        return $ setOnLastLine gpu { mTimer = 0 , currLine = (trs "vbl" (currLine + 1)) }
      OamScan -> return gpu { mTimer = 0, mode = VramScan }
      VramScan -> return $ renderLine gpu { mTimer = 0, mode = HBlank }

renderLine :: Gpu -> Gpu
renderLine gpu = gpu { scrBuf = foldRes.scrBuf }
  {--canvas <- getCanvas--}
  {--setLine (seqToArray foldRes.cnvsLine) gpu.currLine canvas--}
 where
  foldRes = foldl updateCanvas
                  { scrBuf:gpu.scrBuf, tho:tileHorizOff
                  , mho:memHorizOff, tix:tileIx }
                  (0 A... (pixWidth-1))
  tileIx = getTileIx gpu tileIxAddr
  tileIxAddr = bgMapOff + memVertOff + memHorizOff
  --map #0 9800-9BFF, map #1 9C00-9FFF
  bgMapOff = if gpu.bgMap1 then 0x1C00 else 0x1800
  --Each tile's height is 3 bits long,
  --and each map row of tiles is 5 bits (32 tiles wide)
  memVertOff = (pixelVertOff `zshr` 3) `shl` 5
  --The map's height is 256 pixels long
  pixelVertOff = 255 .&. (gpu.currLine + gpu.yScroll)
  -- the map is 32 tiles wide
  memHorizOff = 31 .&. (gpu.xScroll `zshr` 3)
  --tile height is 8 pixels / 3 bits long
  tileVertOff = 7 .&. (gpu.currLine + gpu.yScroll)
  --tile width is 8 pixels / 3 bits wide
  tileHorizOff = 7 .&. gpu.xScroll

  updateCanvas {scrBuf,tho,mho,tix} i =
    {scrBuf:scrBuf',tho:tho',mho:mho',tix:tix'}
   where
    --Would've rewritten with a single 'if', if PureScript had supported
    --pattern matching in where clause
    tix' = if lastTileRowPixel
      then getTileIx gpu $ bgMapOff + memVertOff + mho'
      else tix
    tho' = if lastTileRowPixel
      then 0
      else tho + 1
    mho' = if lastTileRowPixel
      then 31 .&. (1 + mho)
      else mho
    lastTileRowPixel = tho == 7

    {--cnvsOff' = cnvsOff + 4--}
    scrBuf' = foldl S.snoc scrBuf [color.a,color.r,color.g,color.b]

    --NOTE trace error, if invalid color ix
    color = getFromSeq cleanColor colorIx gpu.palette
    colorIx = getTilePixel tho tileVertOff $ getTile tileIx gpu.tiles

--NOTE: Is it necessary to check tix < 128? doesn't map tile #1 always
--use set #1? (which is from -128 to 127)
getTileIx :: Gpu -> I16 -> I8
getTileIx { vram, bgSet1 } addr =
  if bgSet1 && tix < 128 then tix + 256 else tix
 where tix = vram !! addr

--TODO add a generic register sequence
gpuRd8 :: I16 -> Gpu -> I8
gpuRd8 addr gpu = case addr of
  0xFF40 -> getCtrlFlags gpu
  0xFF42 -> gpu.yScroll
  0xFF43 -> gpu.xScroll
  0xFF44 -> gpu.currLine
  0xFF47 -> -1 --NOTE log this, if needed implement getPalette Seq{argb}->I8
  otherwise -> gpu.regs !! addr - 0xFF40

gpuWr8 :: I8 -> I16 -> Gpu -> Gpu
gpuWr8 i8 addr gpu = setRegs $ case addr of
  0xFF40 -> setCtrlFlags
  0xFF42 -> gpu { yScroll = i8 }
  0xFF43 -> gpu { xScroll = i8 }
  0xFF44 -> gpu { currLine = i8 }
  0xFF47 -> setPalette
  otherwise -> gpu
 where
  --NOTE: Might be redundant, consider moving this to otherwise case
  --if it helps performance.
  setRegs = _ { regs = S.replace i8 (addr - 0xFF40) gpu.regs }

  setCtrlFlags = gpu
    { bgOn   = isFlagSet 0x01
    , bgMap1 = isFlagSet 0x08
    , bgSet1 = isFlagSet 0x10
    , dispOn = isFlagSet 0x80
    }
  isFlagSet flag = (flag .&. i8) /= 0

  setPalette = gpu { palette = foldl stPl S.empty (0 A... 3) }
  --Every color is 2 bits wide
  --NOTE should this be reversed?
  stPl plt i = case (i8 `zshr` (i*2)) .&. 3 of
    0 -> S.snoc plt {a:255,r:255,g:255,b:255}
    1 -> S.snoc plt {a:192,r:192,g:192,b:255}
    2 -> S.snoc plt {a:96 ,r:96 ,g:96 ,b:255}
    3 -> S.snoc plt {a:0  ,r:0  ,g:0  ,b:255}
    otherwise -> plt -- NOTE log this

--NOTE gpuwr8 should call this function depending on the addr prefix
wrVRam :: I8 -> I16 -> Gpu -> Gpu
wrVRam i8 addr gpu@{vram,tiles} = gpu { vram = vram', tiles = tiles' }
 where
  vram' = S.replace i8 addr' vram
  tiles' = vramWriteToTiles addr' vram' tiles
  addr' = 0x1FFF .&. addr

--------------TILE--------    R O W
-- b    b b b b    b b b b    b b b b
--Each tile is 8 * 8 pixels * 2 bits per pixel = 16 bytes
--Each row is 8 pixels * 2 bits per pixel = 16 bits = 2 bytes

--Total of 384 TILES from 0x8000 to 0x97FF

--NOTE:potential problem if we write from 0x9800 to 0x9FFF
--which is not the tiles. It is the 2 tile maps.
vramWriteToTiles :: I16 -> S.Seq I8 -> Tiles -> Tiles
vramWriteToTiles addr vram tiles = setTile tile' tileIx tiles
 where
  tile' = foldr updateColor tile (0 A... 7)
  tile = getTile tileIx tiles
  -- Doesn't matter if a byte of LOWER color bit of 8 pixels or HIGHER have
  -- changed, I have to update those 8 pixels colors just the same.
  addr' = addr - (addr .&. 1)
  tileIx = (addr `zshr` 4) .&. 511
  y = (addr `zshr` 1) .&. 7

  updateColor :: Int -> Tile -> Tile
  updateColor x t = setTilePixel c x y t
   where
    shiftMask = 1 `shl` (7-x)
    highColors = vram !! addr + 1
    lowColors = vram !! addr
    c =  (if (shiftMask .&. highColors) /= 0 then 2 else 0)
     .|. (if (shiftMask .&. lowColors) /= 0 then 1 else 0)

--NOTE Add a check that tile index is valid (0<=i<384)

setTile :: Tile -> Int -> Tiles -> Tiles
setTile t i ts = S.replace t i ts

--NOTES  replace fromMaybe with something that will log invalid indices
getTile :: Int -> Tiles -> Tile
getTile ix = getFromSeq cleanTile ix

getTilePixel :: Int -> Int -> Tile -> Int
getTilePixel x y (Tile s) = s !! (y*8 + x)

--NOTE Add a check that indices and color are valid (0<=i<8) (0<=c<4)
setTilePixel :: Int -> Int -> Int -> Tile -> Tile
setTilePixel c x y (Tile s) = Tile $ S.replace c (y*8 + x) s

pixWidth :: Int
pixWidth = 160

bytesWidth :: Int
bytesWidth = 160*4

pixHeight :: Int
pixHeight = 144

module Gpu
  ( resetScreen
  , gpuStep
  , gpuRd8
  , gpuWr8
  , wrVRam
  , cleanGpu
  , module Graphics.Canvas
  ) where

import Prelude
import Control.Bind
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Data.Int
import Data.Int.Bits
import Data.Foldable
import Data.Array as A
import Data.Sequence as S
import Data.Maybe
import Graphics.Canvas

import Types
import Utils

foreign import setScreen :: forall e. Array I8 -> Context2D
                       -> Eff (canvas :: Canvas | e) Unit

resetScreen :: forall e. Eff (canvas :: Canvas | e) Unit
resetScreen = setScreen arr =<< getCanvas
 where
  arr = A.replicate (160*144*4) 255

getCanvas :: forall e. Eff (canvas :: Canvas | e) Context2D
getCanvas = do
  Just canvasElem <- getCanvasElementById "screen"
  getContext2D canvasElem

--NOTE Add a check that tile index is valid (0<=i<384)
setTile :: Tile -> Int -> Tiles -> Tiles
setTile t i ts = S.replace t i ts

--NOTES  replace fromMaybe with something that will log invalid indices
getTile :: Int -> Tiles -> Tile
getTile ix = getFromSeq cleanTile ix

getTilePixel :: Int -> Int -> Tile -> Int
getTilePixel x y (Tile s) = s !! (y*8 + x)

--NOTE Add a check that indices and color are valid (0<=i<8) (0<=c<4)
setTilePixel :: Int -> Int -> Int -> Tile -> Tile
setTilePixel c x y (Tile s) = Tile $ S.replace c (y*8 + x) s

pixWidth :: Int
pixWidth = 160

bytesWidth :: Int
bytesWidth = 160*4

pixHeight :: Int
pixHeight = 144

modeDuration :: GpuMode -> Int
modeDuration = case _ of
  HBlank -> 51
  VBlank -> 114
  VramScan -> 43
  OamScan -> 20

getCtrlFlags :: Gpu -> I8
getCtrlFlags gpu =  cf gpu.bgOn   0x01
                .|. cf gpu.bgMap1 0x08
                .|. cf gpu.bgSet1 0x10
                .|. cf gpu.dispOn 0x80
 where cf bool flag = if bool then flag else 0x00

cleanGpu :: Gpu
cleanGpu =
  { mTimer : 0
  , dispOn : false
  , bgOn : false
  , bgMap1 : false
  , bgSet1 : false
  , scrBuf : S.empty
  , currLine : 0
  , currPos : 0
  , yScroll : 0
  , xScroll : 0
  , palette : S.fromFoldable $ A.replicate 4 cleanColor
  , mode : OamScan
  , tiles : S.fromFoldable $ A.replicate 384 cleanTile
  , regs : S.fromFoldable $ A.replicate 0x40 0
  , vram : S.fromFoldable $ A.replicate 8192 0
  , oam  : S.fromFoldable $ A.replicate 160 0
  }

cleanTile :: Tile
cleanTile = Tile $ S.fromFoldable $ A.replicate 64 0

cleanColor :: Color
cleanColor = {a:0,r:0,g:0,b:0}

gpuStep :: forall e. I8 -> Gpu -> Eff (canvas :: Canvas | e) Gpu
gpuStep mReg gpu@{mTimer,mode,currLine,currPos,scrBuf} = gpu'
 where
  mTimer' = mTimer + mReg

  gpu' = if mTimer' < modeDuration mode
    then return gpu { mTimer = mTimer' }
    else case mode of
      HBlank -> do --TODO set True least significant interrupt flags bit
        when ((trs "currLine" currLine) == pixHeight - 1)
          $ setScreen (seqToArray scrBuf) =<< getCanvas
        return gpu { mTimer = 0
                   , scrBuf = S.empty :: S.Seq I8 --psc forces me here
                   , currLine = currLine + 1
                   , currPos = currPos + bytesWidth
                   , mode = if currLine == pixHeight - 1 then VBlank
                                                         else OamScan
                   }
      VBlank -> do
        let setOnLastLine =
              if currLine == pixHeight + 10 - 1
                -- 10 increments after last line of 143
                then _ { mTimer = 0
                       , currLine = 0
                       , currPos = 0
                       , mode = OamScan
                       }
                else id
        return $ setOnLastLine gpu { mTimer = 0 , currLine = (trs "vbl" (currLine + 1)) }
      OamScan -> return gpu { mTimer = 0, mode = VramScan }
      VramScan -> return $ renderLine gpu { mTimer = 0, mode = HBlank }


C# POCO option

C# POCO option

module Language.CSharp
    ( renderer
    ) where

import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory)
import Data.Foldable (for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Set (Set)
import Data.String.Util (camelCase, legalizeCharacters, startWithLetter, stringEscape, isLetterOrLetterNumber)
import Data.Tuple (Tuple(..))
import Doc (Doc, Renderer, blank, combineNames, forEachProperty_, forEachTopLevel_, getForSingleOrMultipleTopLevels, getModuleName, getTypeNameForUnion, getUnionNames, indent, line, lookupClassName, lookupUnionName, noForbidNamer, renderRenderItems, simpleNamer, transformPropertyNames, unionIsNotSimpleNullable, unionNameIntercalated, getOptionValue)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, Named, forUnion_, isUnionMember, nullableFromUnion, removeNullFromUnion, unionHasArray, unionHasClass, unionHasMap)
import Options (Option, booleanOption, enumOption)

forbiddenNames :: Array String
forbiddenNames = ["Converter", "JsonConverter", "Type", "Serialize"]

listOption :: Option Boolean
listOption = enumOption "array-type" "Select C# type to use for JSON arrays" [Tuple "array" false, Tuple "list" true]

pocoOption :: Option Boolean
pocoOption = booleanOption "poco" "[EXPERIMENTAL] Generate 'Plain Old C# Objects' only" false

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , extension: "cs"
    , doc: csharpDoc
    , options: [listOption.specification, pocoOption.specification]
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelName: noForbidNamer csNameStyle
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer nameForType
            , nameFromTypes: simpleNamer (unionNameIntercalated csNameStyle "Or")
            }
        }
    }

nameForType :: Named (Set String) -> String
nameForType = csNameStyle <<< combineNames

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = nameForType names

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

isStartCharacter :: Char -> Boolean
isStartCharacter c =
    isLetterOrLetterNumber c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    _ -> isStartCharacter c

renderNullableToCSharp :: IRType -> Doc String
renderNullableToCSharp x = do
    rendered <- renderTypeToCSharp x
    pure if isValueType x then rendered <> "?" else rendered

renderUnionToCSharp :: IRUnionRep -> Doc String
renderUnionToCSharp ur =
    case nullableFromUnion ur of
    Just x -> renderNullableToCSharp x
    Nothing -> lookupUnionName ur

renderTypeToCSharp :: IRType -> Doc String
renderTypeToCSharp = case _ of
    IRNoInformation -> pure "FIXME"
    IRAnyType -> pure "object" -- we can have arrays of nothing
    IRNull -> pure "object"
    IRInteger -> pure "long"
    IRDouble -> pure "double"
    IRBool -> pure "bool"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderTypeToCSharp a
        useList <- getOptionValue listOption
        if useList
            then
                pure $ "List<" <> rendered <> ">"
            else
                pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderTypeToCSharp t
        pure $ "Dictionary<string, " <> rendered <> ">"
    IRUnion ur -> renderUnionToCSharp ur

legalize :: String -> String
legalize = legalizeCharacters isPartCharacter

csNameStyle :: String -> String
csNameStyle = legalize >>> camelCase >>> startWithLetter isStartCharacter true

csharpDoc :: Doc Unit
csharpDoc = do
    module_ <- getModuleName csNameStyle
    whenSerializers do
        oneOfThese <- getForSingleOrMultipleTopLevels "" " one of these"
        line $ "// To parse this JSON data, add NuGet 'Newtonsoft.Json' then do" <> oneOfThese <> ":"
        line "//"
        line $ "//    using " <> module_ <> ";"
        forEachTopLevel_ \topLevelName topLevelType -> do
            line "//"
            line $ "//    var data = " <> module_ <> ".FromJson(jsonString);"
        line "//"

    line $ "namespace " <> module_
    line "{"
    indent do
        let using s = line $ "using " <> s <> ";"
        using "System"
        using "System.Net"
        using "System.Collections.Generic"
        whenSerializers do
            blank
            using "Newtonsoft.Json"
        blank
        renderRenderItems blank Nothing renderCSharpClass (Just renderCSharpUnion)
        whenSerializers do
            blank
            renderCSharpClassJSONPartials
            renderRenderItems (pure unit) Nothing (\_ _ -> pure unit) (Just renderCSharpUnionReadWritePartial)
            renderJsonConverter
    line "}"

whenSerializers :: Doc Unit -> Doc Unit
whenSerializers doc = do
    poco <- getOptionValue pocoOption
    unless poco doc

stringIfTrue :: Boolean -> String -> String
stringIfTrue true s = s
stringIfTrue false _ = ""

renderCSharpClassJSONPartials :: Doc Unit
renderCSharpClassJSONPartials = do
    forEachTopLevel_ \topLevelName topLevelType -> do
        blank
        topLevelTypeRendered <- renderTypeToCSharp topLevelType
        line $ "public partial class " <> topLevelName
        line "{"
        indent do
            line
                $ "public static "
                <> topLevelTypeRendered
                <> " "
                <> "FromJson(string json) => JsonConvert.DeserializeObject<"
                <> topLevelTypeRendered
                <> ">(json, Converter.Settings);"
        line "}"

    whenSerializers do
        blank
        line $ "public static class Serialize"
        line "{"
        indent do
            forEachTopLevel_ \topLevelName topLevelType -> do
                topLevelTypeRendered <- renderTypeToCSharp topLevelType
                line $
                    "public static string ToJson(this "
                    <> topLevelTypeRendered
                    <> " self) => JsonConvert.SerializeObject(self, Converter.Settings);"
    line "}"

renderJsonConverter :: Doc Unit
renderJsonConverter = do
    blank
    unionNames <- getUnionNames
    let haveUnions = not $ M.isEmpty unionNames
    let names = M.values unionNames
    line $ "public class Converter" <> stringIfTrue haveUnions ": JsonConverter"
    line "{"
    indent do
        when haveUnions do
            line "public override bool CanConvert(Type t)"
            line "{"
            indent $ line $ "return " <> intercalate " || " (map (\n -> "t == typeof(" <> n <> ")") names) <> ";"
            line "}"
            blank
            line "public override object ReadJson(JsonReader reader, Type t, object existingValue, JsonSerializer serializer)"
            line "{"
            indent do
                -- FIXME: call the constructor via reflection?
                for_ names \name -> do
                    line $ "if (t == typeof(" <> name <> "))"
                    indent $ line $ "return new " <> name <> "(reader, serializer);"
                line "throw new Exception(\"Unknown type\");"
            line "}"

            whenSerializers do
                blank
                line "public override void WriteJson(JsonWriter writer, object value, JsonSerializer serializer)"
                line "{"
                indent do
                    line "var t = value.GetType();"
                    for_ names \name -> do
                        line $ "if (t == typeof(" <> name <> ")) {"
                        indent do
                            line $ "((" <> name <> ")value).WriteJson(writer, serializer);"
                            line "return;"
                        line "}"
                    line "throw new Exception(\"Unknown type\");"
                line "}"
            blank

        line "public static readonly JsonSerializerSettings Settings = new JsonSerializerSettings"
        line "{"
        indent do
            line "MetadataPropertyHandling = MetadataPropertyHandling.Ignore,"
            line "DateParseHandling = DateParseHandling.None,"
            when haveUnions do
                line "Converters = { new Converter() },"
        line "};"
    line "}"

tokenCase :: String -> Doc Unit
tokenCase tokenType =
    line $ "case JsonToken." <> tokenType <> ":"

renderNullDeserializer :: Doc Unit
renderNullDeserializer = do
    tokenCase "Null"
    indent do
        line "break;"

unionFieldName :: IRType -> Doc String
unionFieldName t = csNameStyle <$> getTypeNameForUnion t

deserialize :: String -> String -> Doc Unit
deserialize fieldName typeName = do
    line $ fieldName <> " = serializer.Deserialize<" <> typeName <> ">(reader);"
    line "break;"

deserializeType :: IRType -> Doc Unit
deserializeType t = do
    fieldName <- unionFieldName t
    renderedType <- renderTypeToCSharp t
    deserialize fieldName renderedType

renderPrimitiveDeserializer :: List String -> IRType -> IRUnionRep -> Doc Unit
renderPrimitiveDeserializer tokenTypes t union =
    when (isUnionMember t union) do
        for_ tokenTypes \tokenType -> do
            tokenCase tokenType
        indent do
            deserializeType t

renderDoubleDeserializer :: IRUnionRep -> Doc Unit
renderDoubleDeserializer union =
    when (isUnionMember IRDouble union) do
        unless (isUnionMember IRInteger union) do
            tokenCase "Integer"
        tokenCase "Float"
        indent do
            deserializeType IRDouble

renderGenericDeserializer :: (IRUnionRep -> Maybe IRType) -> String -> IRUnionRep -> Doc Unit
renderGenericDeserializer predicate tokenType union =
    case predicate union of
    Nothing -> pure unit
    Just t -> do
        tokenCase tokenType
        indent do
            deserializeType t

renderCSharpUnion :: String -> IRUnionRep -> Doc Unit
renderCSharpUnion name unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep
    poco <- getOptionValue pocoOption
    line $ "public" <> (if poco then "" else " partial") <> " struct " <> name
    line "{"
    indent do
        forUnion_ nonNullUnion \t -> do
            typeString <- renderNullableToCSharp t
            field <- unionFieldName t
            line $ "public " <> typeString <> " " <> field <> ";"
    line "}"

renderCSharpUnionReadWritePartial :: String -> IRUnionRep -> Doc Unit
renderCSharpUnionReadWritePartial name unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep

    blank
    line $ "public partial struct " <> name
    line "{"
    indent do
        line $ "public " <> name <> "(JsonReader reader, JsonSerializer serializer)"
        line "{"
        indent do
            forUnion_ nonNullUnion \field -> do
                fieldName <- unionFieldName field
                line $ fieldName <> " = null;"
            blank
            line "switch (reader.TokenType)"
            line "{"
            indent do
                when hasNull renderNullDeserializer
                renderPrimitiveDeserializer (L.singleton "Integer") IRInteger nonNullUnion
                renderDoubleDeserializer nonNullUnion
                renderPrimitiveDeserializer (L.singleton "Boolean") IRBool nonNullUnion
                renderPrimitiveDeserializer ("String" : "Date" : L.Nil) IRString nonNullUnion
                renderGenericDeserializer unionHasArray "StartArray" nonNullUnion
                renderGenericDeserializer unionHasClass "StartObject" nonNullUnion
                renderGenericDeserializer unionHasMap "StartObject" nonNullUnion
                line $ "default: throw new Exception(\"Cannot convert " <> name <> "\");"
            line "}"
        line "}"

        blank
        line $ "public void WriteJson(JsonWriter writer, JsonSerializer serializer)"
        line "{"
        indent do
            forUnion_ nonNullUnion \field -> do
                fieldName <- unionFieldName field
                line $ "if (" <> fieldName <> " != null) {"
                indent do
                    line $ "serializer.Serialize(writer, " <> fieldName <> ");"
                    line "return;"
                line "}"
            if hasNull
                then
                    line "writer.WriteNull();"
                else
                    line "throw new Exception(\"Union must not be null\");"
        line "}"
    line "}"

renderCSharpClass :: String -> Map String IRType -> Doc Unit
renderCSharpClass className properties = do
    let propertyNames = transformPropertyNames (simpleNamer csNameStyle) ("Other" <> _) [className] properties
    poco <- getOptionValue pocoOption
    line $ "public" <> (if poco then "" else " partial") <> " class " <> className
    line "{"
    indent do
        forEachProperty_ properties propertyNames \pname ptype csPropName isLast -> do
            whenSerializers do
                line $ "[JsonProperty(\"" <> stringEscape pname <> "\")]"
            rendered <- renderTypeToCSharp ptype
            line $ "public " <> rendered <> " " <> csPropName <> " { get; set; }"
            whenSerializers do
                unless isLast blank
    line "}"

module Language.CSharp
    ( renderer
    ) where

import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory)
import Data.Foldable (for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Set (Set)
import Data.String.Util (camelCase, legalizeCharacters, startWithLetter, stringEscape, isLetterOrLetterNumber)
import Data.Tuple (Tuple(..))
import Doc (Doc, Renderer, blank, combineNames, forEachProperty_, forEachTopLevel_, getForSingleOrMultipleTopLevels, getModuleName, getTypeNameForUnion, getUnionNames, indent, line, lookupClassName, lookupUnionName, noForbidNamer, renderRenderItems, simpleNamer, transformPropertyNames, unionIsNotSimpleNullable, unionNameIntercalated, getOptionValue)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, Named, forUnion_, isUnionMember, nullableFromUnion, removeNullFromUnion, unionHasArray, unionHasClass, unionHasMap)
import Options (enumOption, Option)

forbiddenNames :: Array String
forbiddenNames = ["Converter", "JsonConverter", "Type", "Serialize"]

listOption :: Option Boolean
listOption = enumOption "array-type" "Select C# type to use for JSON arrays" [Tuple "array" false, Tuple "list" true]

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , extension: "cs"
    , doc: csharpDoc
    , options: [listOption.specification]
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelName: noForbidNamer csNameStyle
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: simpleNamer nameForType
            , nameFromTypes: simpleNamer (unionNameIntercalated csNameStyle "Or")
            }
        }
    }

nameForType :: Named (Set String) -> String
nameForType = csNameStyle <<< combineNames

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = nameForType names

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

isStartCharacter :: Char -> Boolean
isStartCharacter c =
    isLetterOrLetterNumber c || c == '_'

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    _ -> isStartCharacter c

renderNullableToCSharp :: IRType -> Doc String
renderNullableToCSharp x = do
    rendered <- renderTypeToCSharp x
    pure if isValueType x then rendered <> "?" else rendered

renderUnionToCSharp :: IRUnionRep -> Doc String
renderUnionToCSharp ur =
    case nullableFromUnion ur of
    Just x -> renderNullableToCSharp x
    Nothing -> lookupUnionName ur

renderTypeToCSharp :: IRType -> Doc String
renderTypeToCSharp = case _ of
    IRNoInformation -> pure "FIXME"
    IRAnyType -> pure "object" -- we can have arrays of nothing
    IRNull -> pure "object"
    IRInteger -> pure "long"
    IRDouble -> pure "double"
    IRBool -> pure "bool"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderTypeToCSharp a
        useList <- getOptionValue listOption
        if useList
            then
                pure $ "List<" <> rendered <> ">"
            else
                pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderTypeToCSharp t
        pure $ "Dictionary<string, " <> rendered <> ">"
    IRUnion ur -> renderUnionToCSharp ur

legalize :: String -> String
legalize = legalizeCharacters isPartCharacter

csNameStyle :: String -> String
csNameStyle = legalize >>> camelCase >>> startWithLetter isStartCharacter true

csharpDoc :: Doc Unit
csharpDoc = do
    module_ <- getModuleName csNameStyle
    oneOfThese <- getForSingleOrMultipleTopLevels "" " one of these"
    line $ "// To parse this JSON data, add NuGet 'Newtonsoft.Json' then do" <> oneOfThese <> ":"
    line "//"
    line $ "//    using " <> module_ <> ";"
    forEachTopLevel_ \topLevelName topLevelType -> do
        line "//"
        line $ "//    var data = " <> module_ <> ".FromJson(jsonString);"
    line "//"
    line $ "namespace " <> module_
    line "{"
    indent do
        line """using System;
using System.Net;
using System.Collections.Generic;

using Newtonsoft.Json;
"""
        renderRenderItems blank Nothing renderCSharpClass (Just renderCSharpUnion)
        renderCSharpClassJSONPartials
        renderRenderItems (pure unit) Nothing (\_ _ -> pure unit) (Just renderCSharpUnionReadWritePartial)
        renderJsonConverter
    line "}"

whenSerializers :: Doc Unit -> Doc Unit
whenSerializers = id

stringIfTrue :: Boolean -> String -> String
stringIfTrue true s = s
stringIfTrue false _ = ""

renderCSharpClassJSONPartials :: Doc Unit
renderCSharpClassJSONPartials = do
    forEachTopLevel_ \topLevelName topLevelType -> do
        blank
        topLevelTypeRendered <- renderTypeToCSharp topLevelType
        line $ "public partial class " <> topLevelName
        line "{"
        indent do
            line
                $ "public static "
                <> topLevelTypeRendered
                <> " "
                <> "FromJson(string json) => JsonConvert.DeserializeObject<"
                <> topLevelTypeRendered
                <> ">(json, Converter.Settings);"
        line "}"

    whenSerializers do
        blank
        line $ "public static class Serialize"
        line "{"
        indent do
            forEachTopLevel_ \topLevelName topLevelType -> do
                topLevelTypeRendered <- renderTypeToCSharp topLevelType
                line $
                    "public static string ToJson(this "
                    <> topLevelTypeRendered
                    <> " self) => JsonConvert.SerializeObject(self, Converter.Settings);"
    line "}"

renderJsonConverter :: Doc Unit
renderJsonConverter = do
    blank
    unionNames <- getUnionNames
    let haveUnions = not $ M.isEmpty unionNames
    let names = M.values unionNames
    line $ "public class Converter" <> stringIfTrue haveUnions ": JsonConverter"
    line "{"
    indent do
        when haveUnions do
            line "public override bool CanConvert(Type t)"
            line "{"
            indent $ line $ "return " <> intercalate " || " (map (\n -> "t == typeof(" <> n <> ")") names) <> ";"
            line "}"
            blank
            line "public override object ReadJson(JsonReader reader, Type t, object existingValue, JsonSerializer serializer)"
            line "{"
            indent do
                -- FIXME: call the constructor via reflection?
                for_ names \name -> do
                    line $ "if (t == typeof(" <> name <> "))"
                    indent $ line $ "return new " <> name <> "(reader, serializer);"
                line "throw new Exception(\"Unknown type\");"
            line "}"

            whenSerializers do
                blank
                line "public override void WriteJson(JsonWriter writer, object value, JsonSerializer serializer)"
                line "{"
                indent do
                    line "var t = value.GetType();"
                    for_ names \name -> do
                        line $ "if (t == typeof(" <> name <> ")) {"
                        indent do
                            line $ "((" <> name <> ")value).WriteJson(writer, serializer);"
                            line "return;"
                        line "}"
                    line "throw new Exception(\"Unknown type\");"
                line "}"
            blank

        line "public static readonly JsonSerializerSettings Settings = new JsonSerializerSettings"
        line "{"
        indent do
            line "MetadataPropertyHandling = MetadataPropertyHandling.Ignore,"
            line "DateParseHandling = DateParseHandling.None,"
            when haveUnions do
                line "Converters = { new Converter() },"
        line "};"
    line "}"

tokenCase :: String -> Doc Unit
tokenCase tokenType =
    line $ "case JsonToken." <> tokenType <> ":"

renderNullDeserializer :: Doc Unit
renderNullDeserializer = do
    tokenCase "Null"
    indent do
        line "break;"

unionFieldName :: IRType -> Doc String
unionFieldName t = csNameStyle <$> getTypeNameForUnion t

deserialize :: String -> String -> Doc Unit
deserialize fieldName typeName = do
    line $ fieldName <> " = serializer.Deserialize<" <> typeName <> ">(reader);"
    line "break;"

deserializeType :: IRType -> Doc Unit
deserializeType t = do
    fieldName <- unionFieldName t
    renderedType <- renderTypeToCSharp t
    deserialize fieldName renderedType

renderPrimitiveDeserializer :: List String -> IRType -> IRUnionRep -> Doc Unit
renderPrimitiveDeserializer tokenTypes t union =
    when (isUnionMember t union) do
        for_ tokenTypes \tokenType -> do
            tokenCase tokenType
        indent do
            deserializeType t

renderDoubleDeserializer :: IRUnionRep -> Doc Unit
renderDoubleDeserializer union =
    when (isUnionMember IRDouble union) do
        unless (isUnionMember IRInteger union) do
            tokenCase "Integer"
        tokenCase "Float"
        indent do
            deserializeType IRDouble

renderGenericDeserializer :: (IRUnionRep -> Maybe IRType) -> String -> IRUnionRep -> Doc Unit
renderGenericDeserializer predicate tokenType union =
    case predicate union of
    Nothing -> pure unit
    Just t -> do
        tokenCase tokenType
        indent do
            deserializeType t

renderCSharpUnion :: String -> IRUnionRep -> Doc Unit
renderCSharpUnion name unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep
    line $ "public partial struct " <> name
    line "{"
    indent do
        forUnion_ nonNullUnion \t -> do
            typeString <- renderNullableToCSharp t
            field <- unionFieldName t
            line $ "public " <> typeString <> " " <> field <> ";"
    line "}"

renderCSharpUnionReadWritePartial :: String -> IRUnionRep -> Doc Unit
renderCSharpUnionReadWritePartial name unionRep = do
    let { hasNull, nonNullUnion } = removeNullFromUnion unionRep

    blank
    line $ "public partial struct " <> name
    line "{"
    indent do
        line $ "public " <> name <> "(JsonReader reader, JsonSerializer serializer)"
        line "{"
        indent do
            forUnion_ nonNullUnion \field -> do
                fieldName <- unionFieldName field
                line $ fieldName <> " = null;"
            blank
            line "switch (reader.TokenType)"
            line "{"
            indent do
                when hasNull renderNullDeserializer
                renderPrimitiveDeserializer (L.singleton "Integer") IRInteger nonNullUnion
                renderDoubleDeserializer nonNullUnion
                renderPrimitiveDeserializer (L.singleton "Boolean") IRBool nonNullUnion
                renderPrimitiveDeserializer ("String" : "Date" : L.Nil) IRString nonNullUnion
                renderGenericDeserializer unionHasArray "StartArray" nonNullUnion
                renderGenericDeserializer unionHasClass "StartObject" nonNullUnion
                renderGenericDeserializer unionHasMap "StartObject" nonNullUnion
                line $ "default: throw new Exception(\"Cannot convert " <> name <> "\");"
            line "}"
        line "}"

        whenSerializers do
            blank
            line $ "public void WriteJson(JsonWriter writer, JsonSerializer serializer)"
            line "{"
            indent do
                forUnion_ nonNullUnion \field -> do
                    fieldName <- unionFieldName field
                    line $ "if (" <> fieldName <> " != null) {"
                    indent do
                        line $ "serializer.Serialize(writer, " <> fieldName <> ");"
                        line "return;"
                    line "}"
                if hasNull
                    then
                        line "writer.WriteNull();"
                    else
                        line "throw new Exception(\"Union must not be null\");"
            line "}"
    line "}"

renderCSharpClass :: String -> Map String IRType -> Doc Unit
renderCSharpClass className properties = do
    let propertyNames = transformPropertyNames (simpleNamer csNameStyle) ("Other" <> _) [className] properties
    line $ "public partial class " <> className
    line "{"
    indent do
        forEachProperty_ properties propertyNames \pname ptype csPropName isLast -> do
            line $ "[JsonProperty(\"" <> stringEscape pname <> "\")]"
            rendered <- renderTypeToCSharp ptype
            line $ "public " <> rendered <> " " <> csPropName <> " { get; set; }"
            unless isLast blank
    line "}"


Make use of TestTuple

Make use of TestTuple

module Test.Data.Tuple where

import Data.Array
import Data.Tuple
import Debug.Trace
import Control.Monad.Eff
import Math
import Test.QuickCheck
import Test.QuickCheck.Tuple
import Test.Classes

type Ty = Tuple [Number] [Number]

main = do

  let tty = TestTuple (Tuple [0] [1])

  trace "test equality"
  check2 $ \x y -> Tuple x y == Tuple x y

  trace "test inequality"
  check2 $ \x y -> not $ Tuple x y == Tuple (x + 1) y

  trace "test ordering on the first element"
  check3 \a b x -> compare (Tuple a x) (Tuple b x) == compare a b

  trace "test ordering on the second element (when first element is equal)"
  check3 \a b x -> compare (Tuple x a) (Tuple x b) == compare a b

  trace "test functor laws"
  checkFunctor tty

  trace "test applicative laws"
  checkApplicative tty tty tty

  trace "test monad laws"
  checkMonad tty

  trace "fst should return the first element"
  check2 $ \x y -> fst (Tuple x y) == x

  trace "snd should return the second element"
  check2 $ \x y -> snd (Tuple x y) == y

  trace "curry should maintain argument order"
  check2 $ \x y -> curry (\(Tuple x y) -> x / y) x y == x / y

  trace "uncurry should maintain argument order"
  check2 $ \x y -> uncurry (\x y -> x / y) (Tuple x y) == x / y

  trace "zip should produce a list that matches the length of the shorter input"
  let testZipSize :: [Number] -> [Number] -> Boolean
      testZipSize xs ys = min (length xs) (length ys) == length (zip xs ys)
  quickCheck testZipSize

  trace "zip should produce a list of tuples maintaining argument order"
  let testZipPairs :: [Number] -> [Number] -> Boolean
      testZipPairs xs ys = compareZip xs ys (zip xs ys)
  quickCheck testZipPairs

  trace "unzip should produce a tuple of lists that match the input length"
  let testUnzipSize :: [TestTuple Number Number] -> Boolean
      testUnzipSize ts = case unzip (map runTestTuple ts) of
        (Tuple xs ys) -> length ts == length xs && length ts == length ys
  quickCheck testUnzipSize

  trace "unzip should produce tuple of a lists with elements in the original order"
  let testUnzipPairs :: [TestTuple Number Number] -> Boolean
      testUnzipPairs ts =
        let ts' = map runTestTuple ts in
        case unzip ts' of
          (Tuple xs ys) -> compareZip xs ys ts'
  quickCheck testUnzipPairs

  trace "swap should switch the first and second element"
  check2 $ \x y -> swap (Tuple x y) == (Tuple y x)

check2 :: (Number -> Number -> Boolean) -> QC {}
check2 = quickCheck

check3 :: (Number -> Number -> Number -> Boolean) -> QC {}
check3 = quickCheck

compareZip :: forall a b. (Eq a, Eq b) => [a] -> [b] -> [Tuple a b] -> Boolean
compareZip (x : xs) (y : ys) ((Tuple x' y') : ts) = x == x' && y == y' && compareZip xs ys ts
compareZip [] _  [] = true
compareZip _  [] [] = true
compareZip _  _  _  = false

module Test.Data.Tuple where

import Data.Array
import Data.Tuple
import Debug.Trace
import Control.Monad.Eff
import Math
import Test.QuickCheck
import Test.QuickCheck.Tuple
import Test.Classes

type Ty = Tuple [Number] [Number]

instance arbTuple :: (Arbitrary a, Arbitrary b) => Arbitrary (Tuple a b) where
  arbitrary = runTestTuple <$> arbitrary

main = do

  let ty = Tuple [0] [1]

  trace "test equality"
  check2 $ \x y -> Tuple x y == Tuple x y

  trace "test inequality"
  check2 $ \x y -> not $ Tuple x y == Tuple (x + 1) y

  trace "test ordering on the first element"
  check3 \a b x -> compare (Tuple a x) (Tuple b x) == compare a b

  trace "test ordering on the second element (when first element is equal)"
  check3 \a b x -> compare (Tuple x a) (Tuple x b) == compare a b

  trace "test functor laws"
  checkFunctor ty

  trace "test applicative laws"
  checkApplicative ty ty ty

  trace "test monad laws"
  checkMonad ty

  trace "fst should return the first element"
  check2 $ \x y -> fst (Tuple x y) == x

  trace "snd should return the second element"
  check2 $ \x y -> snd (Tuple x y) == y

  trace "curry should maintain argument order"
  check2 $ \x y -> curry (\(Tuple x y) -> x / y) x y == x / y

  trace "uncurry should maintain argument order"
  check2 $ \x y -> uncurry (\x y -> x / y) (Tuple x y) == x / y

  trace "zip should produce a list that matches the length of the shorter input"
  let testZipSize :: [Number] -> [Number] -> Boolean
      testZipSize xs ys = min (length xs) (length ys) == length (zip xs ys)
  quickCheck testZipSize

  trace "zip should produce a list of tuples maintaining argument order"
  let testZipPairs :: [Number] -> [Number] -> Boolean
      testZipPairs xs ys = compareZip xs ys (zip xs ys)
  quickCheck testZipPairs

  trace "unzip should produce a tuple of lists that match the input length"
  let testUnzipSize :: [TestTuple Number Number] -> Boolean
      testUnzipSize ts = case unzip (map runTestTuple ts) of
        (Tuple xs ys) -> length ts == length xs && length ts == length ys
  quickCheck testUnzipSize

  trace "unzip should produce tuple of a lists with elements in the original order"
  let testUnzipPairs :: [TestTuple Number Number] -> Boolean
      testUnzipPairs ts =
        let ts' = map runTestTuple ts in
        case unzip ts' of
          (Tuple xs ys) -> compareZip xs ys ts'
  quickCheck testUnzipPairs

  trace "swap should switch the first and second element"
  check2 $ \x y -> swap (Tuple x y) == (Tuple y x)

check2 :: (Number -> Number -> Boolean) -> QC {}
check2 = quickCheck

check3 :: (Number -> Number -> Number -> Boolean) -> QC {}
check3 = quickCheck

instance arbAToTupleBC :: (Arbitrary (a -> b), Arbitrary (a -> c)) => Arbitrary (a -> Tuple b c) where
  arbitrary = do
    f <- arbitrary
    g <- arbitrary
    return $ \x -> Tuple (f x) (g x)

compareZip :: forall a b. (Eq a, Eq b) => [a] -> [b] -> [Tuple a b] -> Boolean
compareZip (x : xs) (y : ys) ((Tuple x' y') : ts) = x == x' && y == y' && compareZip xs ys ts
compareZip [] _  [] = true
compareZip _  [] [] = true
compareZip _  _  _  = false


Add `Testable (Gen prop)` instance

Add `Testable (Gen prop)` instance

-- | This module is a partial port of the Haskell QuickCheck library.
-- |
-- | QuickCheck provides a way to write _property-based_ tests.
-- |
-- | The `Arbitrary` and `CoArbitrary` type classes allow us to create
-- | random data with which we can run our tests. This module provides
-- | instances of both classes for PureScript's core data structures,
-- | as well as functions for writing new instances.
-- |
-- | Test suites can use the `quickCheck` and `quickCheckPure` functions
-- | to test properties.
-- |
-- | For example:
-- |
-- | ```purescript
-- | main = quickCheck \n -> n + 1 > n
-- | ```
module Test.QuickCheck
  ( QC
  , quickCheck
  , quickCheck'
  , quickCheckWithSeed
  , quickCheckPure
  , class Testable
  , test
  , Result(..)
  , withHelp
  , (<?>)
  , assertEquals
  , (===)
  , assertNotEquals
  , (/==)
  , module Test.QuickCheck.LCG
  , module Test.QuickCheck.Arbitrary
  ) where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION, throwException, error)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Rec.Class (Step(..), tailRec)

import Data.Foldable (for_)
import Data.List (List)
import Data.Maybe (Maybe(..))
import Data.Maybe.First (First(..))
import Data.Monoid (mempty)
import Data.Tuple (Tuple(..))
import Data.Unfoldable (replicateA)

import Test.QuickCheck.Arbitrary (class Arbitrary, arbitrary, class Coarbitrary, coarbitrary)
import Test.QuickCheck.Gen (Gen, evalGen, runGen)
import Test.QuickCheck.LCG (Seed, runSeed, randomSeed)

-- | A type synonym which represents the effects used by the `quickCheck` function.
type QC eff a = Eff (console :: CONSOLE, random :: RANDOM, err :: EXCEPTION | eff) a

-- | Test a property.
-- |
-- | This function generates a new random seed, runs 100 tests and
-- | prints the test results to the console.
quickCheck :: forall eff prop. Testable prop => prop -> QC eff Unit
quickCheck prop = quickCheck' 100 prop

-- | A variant of the `quickCheck` function which accepts an extra parameter
-- | representing the number of tests which should be run.
quickCheck' :: forall eff prop. Testable prop => Int -> prop -> QC eff Unit
quickCheck' n prop = do
  seed <- randomSeed
  quickCheckWithSeed seed n prop

-- | A variant of the `quickCheck'` function that accepts a specific seed as
-- | well as the number tests that should be run.
quickCheckWithSeed
  :: forall eff prop. Testable prop => Seed -> Int -> prop -> QC eff Unit
quickCheckWithSeed seed n prop = do
  let result = tailRec loop { seed, index: 0, successes: 0, firstFailure: mempty }
  log $ show result.successes <> "/" <> show n <> " test(s) passed."
  for_ result.firstFailure \{ index, message, seed: failureSeed } ->
    throwException $ error
      $ "Test " <> show (index + 1)
      <> " (seed " <> show (runSeed failureSeed) <> ") failed: \n"
      <> message
  where
  loop :: LoopState -> Step LoopState LoopState
  loop state@{ seed, index, successes, firstFailure }
    | index == n = Done state
    | otherwise =
        case runGen (test prop) { newSeed: seed, size: 10 } of
          Tuple Success s ->
            Loop
              { seed: s.newSeed
              , index: index + 1
              , successes: successes + 1
              , firstFailure
              }
          Tuple (Failed message) s ->
            Loop
              { seed: s.newSeed
              , index: index + 1
              , successes
              , firstFailure:
                  firstFailure <> First (Just { index, message, seed })
              }

type LoopState =
  { successes :: Int
  , firstFailure :: First { index :: Int, message :: String, seed :: Seed }
  , seed :: Seed
  , index :: Int
  }

-- | Test a property, returning all test results as an array.
-- |
-- | The first argument is the _random seed_ to be passed to the random generator.
-- | The second argument is the number of tests to run.
quickCheckPure :: forall prop. Testable prop => Seed -> Int -> prop -> List Result
quickCheckPure s n prop = evalGen (replicateA n (test prop)) { newSeed: s, size: 10 }

-- | The `Testable` class represents _testable properties_.
-- |
-- | A testable property is a function of zero or more `Arbitrary` arguments,
-- | returning a `Boolean` or `Result`.
-- |
-- | Testable properties can be passed to the `quickCheck` function.
class Testable prop where
  test :: prop -> Gen Result

instance testableResult :: Testable Result where
  test = pure

instance testableBoolean :: Testable Boolean where
  test true = pure Success
  test false = pure $ Failed "Test returned false"

instance testableFunction :: (Arbitrary t, Testable prop) => Testable (t -> prop) where
  test f = arbitrary >>= test <<< f

instance testableGen :: Testable prop => Testable (Gen prop) where
  test = flip bind test

-- | The result of a test: success or failure (with an error message).
data Result = Success | Failed String

instance showResult :: Show Result where
  show Success = "Success"
  show (Failed msg) = "Failed: " <> msg

-- | This operator attaches an error message to a failed test.
-- |
-- | For example:
-- |
-- | ```purescript
-- | test x = myProperty x <?> ("myProperty did not hold for " <> show x)
-- | ```
withHelp :: Boolean -> String -> Result
withHelp true _ = Success
withHelp false msg = Failed msg

infix 2 withHelp as <?>

-- | Self-documenting equality assertion
assertEquals :: forall a. (Eq a, Show a) => a -> a -> Result
assertEquals a b = a == b <?> show a <> " /= " <> show b

infix 2 assertEquals as ===

-- | Self-documenting inequality assertion
assertNotEquals :: forall a. (Eq a, Show a) => a -> a -> Result
assertNotEquals a b = a /= b <?> show a <> " == " <> show b

infix 2 assertNotEquals as /==

-- | This module is a partial port of the Haskell QuickCheck library.
-- |
-- | QuickCheck provides a way to write _property-based_ tests.
-- |
-- | The `Arbitrary` and `CoArbitrary` type classes allow us to create
-- | random data with which we can run our tests. This module provides
-- | instances of both classes for PureScript's core data structures,
-- | as well as functions for writing new instances.
-- |
-- | Test suites can use the `quickCheck` and `quickCheckPure` functions
-- | to test properties.
-- |
-- | For example:
-- |
-- | ```purescript
-- | main = quickCheck \n -> n + 1 > n
-- | ```
module Test.QuickCheck
  ( QC
  , quickCheck
  , quickCheck'
  , quickCheckWithSeed
  , quickCheckPure
  , class Testable
  , test
  , Result(..)
  , withHelp
  , (<?>)
  , assertEquals
  , (===)
  , assertNotEquals
  , (/==)
  , module Test.QuickCheck.LCG
  , module Test.QuickCheck.Arbitrary
  ) where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION, throwException, error)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Rec.Class (Step(..), tailRec)

import Data.Foldable (for_)
import Data.List (List)
import Data.Maybe (Maybe(..))
import Data.Maybe.First (First(..))
import Data.Monoid (mempty)
import Data.Tuple (Tuple(..))
import Data.Unfoldable (replicateA)

import Test.QuickCheck.Arbitrary (class Arbitrary, arbitrary, class Coarbitrary, coarbitrary)
import Test.QuickCheck.Gen (Gen, evalGen, runGen)
import Test.QuickCheck.LCG (Seed, runSeed, randomSeed)

-- | A type synonym which represents the effects used by the `quickCheck` function.
type QC eff a = Eff (console :: CONSOLE, random :: RANDOM, err :: EXCEPTION | eff) a

-- | Test a property.
-- |
-- | This function generates a new random seed, runs 100 tests and
-- | prints the test results to the console.
quickCheck :: forall eff prop. Testable prop => prop -> QC eff Unit
quickCheck prop = quickCheck' 100 prop

-- | A variant of the `quickCheck` function which accepts an extra parameter
-- | representing the number of tests which should be run.
quickCheck' :: forall eff prop. Testable prop => Int -> prop -> QC eff Unit
quickCheck' n prop = do
  seed <- randomSeed
  quickCheckWithSeed seed n prop

-- | A variant of the `quickCheck'` function that accepts a specific seed as
-- | well as the number tests that should be run.
quickCheckWithSeed
  :: forall eff prop. Testable prop => Seed -> Int -> prop -> QC eff Unit
quickCheckWithSeed seed n prop = do
  let result = tailRec loop { seed, index: 0, successes: 0, firstFailure: mempty }
  log $ show result.successes <> "/" <> show n <> " test(s) passed."
  for_ result.firstFailure \{ index, message, seed: failureSeed } ->
    throwException $ error
      $ "Test " <> show (index + 1)
      <> " (seed " <> show (runSeed failureSeed) <> ") failed: \n"
      <> message
  where
  loop :: LoopState -> Step LoopState LoopState
  loop state@{ seed, index, successes, firstFailure }
    | index == n = Done state
    | otherwise =
        case runGen (test prop) { newSeed: seed, size: 10 } of
          Tuple Success s ->
            Loop
              { seed: s.newSeed
              , index: index + 1
              , successes: successes + 1
              , firstFailure
              }
          Tuple (Failed message) s ->
            Loop
              { seed: s.newSeed
              , index: index + 1
              , successes
              , firstFailure:
                  firstFailure <> First (Just { index, message, seed })
              }

type LoopState =
  { successes :: Int
  , firstFailure :: First { index :: Int, message :: String, seed :: Seed }
  , seed :: Seed
  , index :: Int
  }

-- | Test a property, returning all test results as an array.
-- |
-- | The first argument is the _random seed_ to be passed to the random generator.
-- | The second argument is the number of tests to run.
quickCheckPure :: forall prop. Testable prop => Seed -> Int -> prop -> List Result
quickCheckPure s n prop = evalGen (replicateA n (test prop)) { newSeed: s, size: 10 }

-- | The `Testable` class represents _testable properties_.
-- |
-- | A testable property is a function of zero or more `Arbitrary` arguments,
-- | returning a `Boolean` or `Result`.
-- |
-- | Testable properties can be passed to the `quickCheck` function.
class Testable prop where
  test :: prop -> Gen Result

instance testableResult :: Testable Result where
  test = pure

instance testableBoolean :: Testable Boolean where
  test true = pure Success
  test false = pure $ Failed "Test returned false"

instance testableFunction :: (Arbitrary t, Testable prop) => Testable (t -> prop) where
  test f = arbitrary >>= test <<< f

-- | The result of a test: success or failure (with an error message).
data Result = Success | Failed String

instance showResult :: Show Result where
  show Success = "Success"
  show (Failed msg) = "Failed: " <> msg

-- | This operator attaches an error message to a failed test.
-- |
-- | For example:
-- |
-- | ```purescript
-- | test x = myProperty x <?> ("myProperty did not hold for " <> show x)
-- | ```
withHelp :: Boolean -> String -> Result
withHelp true _ = Success
withHelp false msg = Failed msg

infix 2 withHelp as <?>

-- | Self-documenting equality assertion
assertEquals :: forall a. (Eq a, Show a) => a -> a -> Result
assertEquals a b = a == b <?> show a <> " /= " <> show b

infix 2 assertEquals as ===

-- | Self-documenting inequality assertion
assertNotEquals :: forall a. (Eq a, Show a) => a -> a -> Result
assertNotEquals a b = a /= b <?> show a <> " == " <> show b

infix 2 assertNotEquals as /==


Fix bug

Fix bug

module Graphics.D3.Tip
       (Tip()
       , Direction()
       , attr
       , tip
       , show
       , hide
       , style
       , direction
       , offset
       , html
       , destroy
       , call
       ) where

import Data.Foreign.EasyFFI
import Graphics.D3.Base
import Graphics.D3.Selection (Selection(), Existing)
import Prelude (Show)

data Direction = N | S | E | W | NW | SW | NE | SE

ffi = unsafeForeignFunction

foreign import data Tip :: *

foreign import tip :: D3Eff Tip

show :: Tip -> D3Eff Tip
show = ffi ["tip", ""] "tip.show()"

hide :: Tip -> D3Eff Tip
hide = ffi ["tip", ""] "tip.hide()"

attr :: String -> String -> Tip -> D3Eff Tip
attr = ffi ["n", "v", "tip", ""] "tip.attr(n, v)"

style :: String -> String -> Tip -> D3Eff Tip
style = ffi ["n", "v", "tip", ""] "tip.style(n,v)"

tipDirection :: String -> Tip -> D3Eff Tip
tipDirection = ffi ["v", "tip", ""] "tip.direction(v)"

direction :: Direction -> Tip -> D3Eff Tip
direction N = tipDirection "n"
direction S = tipDirection "s"
direction E = tipDirection "e"
direction W = tipDirection "w"
direction NW = tipDirection "nw"
direction SW = tipDirection "sw"
direction NE = tipDirection "ne"
direction SE = tipDirection "se"

tipOffset :: Array Number -> Tip -> D3Eff Tip
tipOffset = ffi ["v", "tip", ""] "tip.offset(v)"

offset :: Number -> Number -> Tip -> D3Eff Tip
offset x y = tipOffset ([x, y])

html :: (forall a. a -> String) -> Tip -> D3Eff Tip
html = ffi ["fn", "tip", ""] "tip.html(fn)"

destroy :: Tip -> D3Eff Tip
destroy = ffi ["tip", ""] "tip.destroy()"

call :: forall s d. (Existing s) => Tip -> s d -> D3Eff (Selection d)
call = ffi ["tip", "selection", ""] "selection.call(tip)"

module Graphics.D3.Tip
       (Tip()
       , Direction()
       , attr
       , tip
       , show
       , hide
       , style
       , direction
       , offset
       , html
       , destroy
       , call
       ) where

import Data.Foreign.EasyFFI
import Graphics.D3.Base
import Graphics.D3.Selection (Selection(), Existing)
import Prelude (Show)

data Direction = N | S | E | W | NW | SW | NE | SE

ffi = unsafeForeignFunction

foreign import data Tip :: *

foreign import tip :: D3Eff Tip

show :: D3Eff Tip
show = ffi [] "tip.show()"

hide :: D3Eff Tip
hide = ffi [] "tip.hide()"

attr :: String -> String -> D3Eff Tip
attr = ffi ["n", "v"] "tip.attr(n, v)"

style :: String -> String -> D3Eff Tip
style = ffi ["n", "v"] "tip.style(n,v)"

tipDirection :: String -> D3Eff Tip
tipDirection = ffi ["v"] "tip.direction(v)"

direction :: Direction -> D3Eff Tip
direction N = tipDirection "n"
direction S = tipDirection "s"
direction E = tipDirection "e"
direction W = tipDirection "w"
direction NW = tipDirection "nw"
direction SW = tipDirection "sw"
direction NE = tipDirection "ne"
direction SE = tipDirection "se"

tipOffset :: Array Number -> D3Eff Tip
tipOffset = ffi ["v"] "tip.offset(v)"

offset :: Number -> Number -> D3Eff Tip
offset x y = tipOffset ([x, y])

html :: (forall a. a -> String) -> D3Eff Tip
html = ffi ["fn"] "tip.html(fn)"

destroy :: D3Eff Tip
destroy = ffi [] "tip.destroy()"

call :: forall s d. (Existing s) => Tip -> s d -> D3Eff (Selection d)
call = ffi ["tip", "selection", ""] "selection.call(tip)"


First implementation of a TextCursor

First implementation of a TextCursor

module Scansion where

import Prelude
import UIHelpers
import CSS as CSS
import CSS.Overflow as CSS.Overflow
import CSS.TextAlign as CSS.TextAlign
import DOM.Event.Event as Event
import DOM.HTML.HTMLInputElement as HInput
import DOM.HTML.HTMLTextAreaElement as HTextArea
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import ArrayState (evalArrayState, evalReversedArrayState, sequence, sequenceReversed)
import CSS (CSS, StyleM, ex, fromHexString, nil, value)
import CSS.Common (auto)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.State (State)
import Control.Monad.State.Trans (get, put)
import Control.Plus (empty)
import DOM (DOM)
import DOM.Event.Types (Event)
import DOM.HTML.Types (HTMLInputElement, HTMLTextAreaElement)
import Data.Array (filter, mapWithIndex) as Array
import Data.Generic (class Generic, gCompare, gEq, gShow)
import Data.Int (odd)
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.String (Pattern(..), indexOf, joinWith, length, splitAt, trim)
import Data.String (split) as String
import Data.String.Regex (Regex, replace, split, test)
import Data.String.Regex.Flags (global, ignoreCase, noFlags)
import Data.String.Regex.Unsafe (unsafeRegex)
import Data.Tuple (Tuple(..), fst, snd)
import Halogen.Aff (HalogenEffects)
import Halogen.Aff.Util (awaitBody, runHalogenAff)
import Halogen.HTML.CSS (style)
import Halogen.VDom.Driver (runUI)
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

newtype Line =
    Line (Array Res)

instance showLine :: Show Line where
    show (Line line) = joinWith "" do
        res <- line
        pure case res of
            Punct s -> s
            Verb { syllables } ->
                joinWith "" do
                    Syllable { value, stype } <- syllables
                    --pure (value <> show stype)
                    pure value

instance displayLine :: Display Line where
    display line_@(Line line) =
        HH.div_ [ scanned, raw ]
        where
            raw = HH.span [ style $ zindex 1 ] [ HH.text $ show line_ ]
            scanned = HH.div [ divstyle ] $ evalArrayState (map mapper line) 0.0
            divstyle = style do
                CSS.height (1.2#ex)
                zindex (-1)
                no_pointer_events
            mapper (Punct "\n") = pure HH.br_
            mapper (Punct s) = pure (spacer $ HH.text s)
            mapper (Verb { syllables, gloss }) =
                map HH.span_ $ sequence $ map displaySyllableColored syllables

y_mark :: forall a b. CSS -> HP.IProp ( style :: String | a ) b
y_mark extra =
    style do
        CSS.color (unsafePartial $ fromJust $ fromHexString "#F50057")
        CSS.Overflow.overflow CSS.Overflow.visible
        CSS.height (ex 1.0)
        scale 2.0 1.4
        no_user_select
        CSS.margin auto auto auto auto
        CSS.TextAlign.textAlign CSS.TextAlign.center
        extra

instance displaySyllable :: Display Syllable where
    display = displaySyllableStyled (CSS.height nil)

displaySyllableStyled :: forall a b. CSS -> Syllable -> HH.HTML a b
displaySyllableStyled extraStyle (Syllable { value, stype }) =
    HH.div
        [ style do
            CSS.display CSS.inlineBlock
        ]
        [ HH.div [ y_mark extraStyle ] [ HH.text $ show stype ]
        , spacer $ HH.text value
        ]

displaySyllableColored :: forall a b. Syllable -> State Number (HH.HTML a b)
displaySyllableColored syllable@(Syllable { value, stype }) = do
    position <- get
    let incr = case stype of
            Elided ->
                0.0

            Long ->
                1.0

            Ambiguous (Just a) | a ->
                1.0

            _ ->
                0.5
    put (position + incr)
    let clr =
            CSS.color $ fromMaybe (CSS.gray) $ CSS.fromHexString $
                case position of
                    0.0 ->
                        "#F50057"

                    2.0 ->
                        "#D500F9"

                    4.0 ->
                        "#651FFF"

                    6.0 ->
                        "#00E5FF"

                    8.0 ->
                        "#1DE9B6"

                    10.0 ->
                        "#00E676"

                    11.0 ->
                        "#2E7D32"

                    10.5 ->
                        "#FF3D00"

                    11.5 ->
                        "#FF3D00"

                    12.0 ->
                        "#FF3D00"

                    _ ->
                        ""
    pure $ displaySyllableStyled (clr) syllable

data Res
    = Punct String
    | Verb Word

type Word =
    { syllables :: Array Syllable
    , gloss :: String
    }

newtype Syllable = Syllable
    { value :: String
    , stype :: SyllableType
    }

data SyllableType
    = Long
    | Ambiguous (Maybe Boolean)
    | Short
    | Elided

instance showSyllableType :: Show SyllableType where
    show s =
        case s of
            Short ->
                "˘"

            Long ->
                "¯"

            Elided ->
                "˙"

            Ambiguous Nothing ->
                "˟"

            Ambiguous (Just b)
                | b -> "˜"
                | otherwise -> "ˇ"

startsWith :: Pattern -> String -> Boolean
startsWith p s = case indexOf p s of
    Just 0 -> true
    _ -> false

weight :: String -> ScanBias
weight syllable =
    if startsWith (Pattern "x") syllable || startsWith (Pattern "z") syllable then
        IntoDoubleConsonant
    else if test r_cx syllable then
        IntoConsonant
    else
        IntoVowel

data ScanBias = Elidable | IntoVowel | IntoConsonant | IntoDoubleConsonant | LineEnd
derive instance genericScanBias :: Generic ScanBias

instance showScanBias :: Show ScanBias where
  show = gShow

instance eqScanBias :: Eq ScanBias where
  eq = gEq

instance ordScanBias :: Ord ScanBias where
  compare = gCompare

reform :: Syllable -> ScanBias -> SyllableType
reform _ IntoDoubleConsonant = Long
reform (Syllable {stype: Ambiguous _}) LineEnd = Long
reform (Syllable {stype: Short}) LineEnd = Ambiguous Nothing
reform (Syllable {value}) Elidable
    | test r_elision value = Elided
reform (Syllable {stype: Ambiguous Nothing}) IntoVowel = Ambiguous (Just false)
reform (Syllable {stype: Ambiguous Nothing}) Elidable = Ambiguous (Just false)
reform (Syllable {stype: Ambiguous Nothing}) IntoConsonant = Ambiguous (Just true)
reform (Syllable {stype}) _ = stype

resimplify :: Boolean -> SyllableType -> SyllableType
resimplify true (Ambiguous (Just false)) = Short
resimplify true (Ambiguous (Just true)) = Long
resimplify _ stype = stype

inner :: Boolean -> Syllable -> State ScanBias Syllable
inner simplify syllable@(Syllable {value}) = do
    bias <- get
    put (weight value)
    let stype = resimplify simplify $ reform syllable bias
    pure (Syllable { value, stype })

middle :: Boolean -> Array Syllable -> State ScanBias (Array Syllable)
middle simplify syllables = sequenceReversed $ map (inner simplify) syllables

outer :: Boolean -> Res -> State ScanBias Res
outer simplify (Verb w) = do
    bias <- get
    case bias of
        IntoVowel -> put Elidable
        -- double consonants do not affect preceding word in scansion
        IntoDoubleConsonant -> put IntoConsonant
        _ -> pure unit
    syllables <- middle simplify w.syllables
    pure $ Verb { syllables, gloss: w.gloss }
outer _ (res@Punct "\n") = do
    put LineEnd
    pure res
outer _ res = pure res

rescan :: Boolean -> Line -> Line
rescan simplify (Line line) = Line rescanned
    where
        rescanned = evalReversedArrayState statecomputation LineEnd
        statecomputation = map (outer simplify) line

v :: String
v =
    "(?:[aeiouy]͡[aeiouyāēīōūȳ]̄?|(?:a[eu]|oe|eu)(?![̄̈])|[aeiouyāēīōūȳ]̄?|[aeiouy]̄|[äëïöüÿ])"

c :: String
c =
    "(?:[qg]u(?=" <> v <> ")|[ck]h|[bcdfghjklmnprstvwxz]|\\bi(?=" <> v <> "))"

l :: String
l =
    "(?:" <> c <> "|" <> v <> ")"

r_word :: Regex
r_word =
    unsafeRegex ("((?:" <> c <> "|" <> v <> ")+)") (ignoreCase <> global)

r_syllable :: Regex
r_syllable =
    unsafeRegex (c <> "*" <> v <> "(" <> c <> "*$|(?![dbpckgt][rl])" <> c <> "((?=" <> c <> "+" <> v <> "?))" <> ")?") (ignoreCase <> global)

r_short :: Regex
r_short =
    unsafeRegex ("(\\bi?|[^aeiouy]|[qg]u)[aeiouy]$") ignoreCase

r_long :: Regex
r_long =
    unsafeRegex ("[aeiouy]̄|[āēīōūȳ]|a[eu]|oe|eu|(x|z|" <> c <> c <> ")$") ignoreCase

r_cx :: Regex
r_cx =
    unsafeRegex ("^((?!h)" <> c <> "|[ij]" <> v <> "|[aeiouy]̄|[äëïöüÿ])") ignoreCase

r_elision :: Regex
r_elision =
    unsafeRegex (v <> "m?$") ignoreCase

r_wordbreak :: Regex
r_wordbreak =
    unsafeRegex ("(?:(?:^|" <> l <> ")" <> l <> "*(?=))") ignoreCase

foreign import _findall :: Regex -> String -> Array String

mksyllables :: String -> Array Syllable
mksyllables content =
    content # _findall r_syllable # map mksyllable
    --content # Regex.find Regex.All r_syllable # map (_.match >>> syllable)
    --content # Regex.match r_syllable # fromMaybe [] # map (_.match >>> syllable)

mksyllable :: String -> Syllable
mksyllable s = Syllable
    { value: s
    , stype:
        if test r_short s then
            Short
        else if test r_long s then
            Long
        else
            Ambiguous Nothing
    }

mkline :: Boolean -> String -> Line
mkline simplify content =
    content # mkwords # Array.filter nonempty # Line # rescan simplify
    where
        nonempty (Punct "") = false
        nonempty (Verb { syllables: [] }) = false
        nonempty _ = true

mklines :: Boolean -> String -> Array Line
mklines simplify content =
    trim content # String.split (Pattern "\n") # map (trim >>> mkline simplify)

processtext :: (String -> Res) -> (String -> Res) -> String -> Array Res
processtext mkverb mkpunct =
    let
        mapper i
            | odd i = mkverb
            | otherwise = mkpunct
    in
        Array.mapWithIndex mapper <<< split r_word

mkwords :: String -> Array Res
mkwords content =
    --content # split r_word # map (\s -> Verb { syllables: mksyllables s, gloss: s})
    processtext (\s -> Verb $ { syllables: mksyllables s, gloss: s }) Punct content

data Query a
    = ToggleState a
    | UserInput Event a

type UIState =
    { simplify :: Boolean
    , text :: TextCursor
    }

initialState :: UIState
initialState =
    { simplify: true
    , text: TextCursor
        { before: """arma virumque canō, Trōiae quī prīmus ab ōrīs"""
        , selected: "\n"
        , after: """Ītaliam fātō profugus Lāvīni͡aque vēnit"""
        }
    }

legend :: forall a b. Boolean -> HH.HTML a b
legend true =
    HH.div_/>"¯ a long (heavy) syllable, ˘ a short syllable"
legend false =
    HH.div_/>"¯ a long (heavy) syllable, ˜ a syllable long by position, ˇ a syllable short by position, ˘ a short syllable"

newtype TextCursor = TextCursor
    { before :: String
    , selected :: String
    , after :: String
    }

splitAtTuple :: Int -> String -> Tuple String String
splitAtTuple i s = case splitAt i s of
    Just [first, second] -> Tuple first second
    _ | i > 0     -> Tuple s ""
      | otherwise -> Tuple "" s

textCursor :: forall eff. HTMLTextAreaElement -> Eff ( dom :: DOM | eff ) TextCursor
textCursor element = do
    value <- HTextArea.value element
    start <- HTextArea.selectionStart element
    end <- HTextArea.selectionEnd element
    let prior_after = splitAtTuple end value
    let prior = fst prior_after
    let after = snd prior_after
    let before_selected = splitAtTuple start prior
    let before = fst before_selected
    let selected = snd before_selected
    pure $ TextCursor
        { before
        , selected
        , after
        }

setTextCursor :: forall eff. TextCursor -> HTMLTextAreaElement -> Eff ( dom :: DOM | eff ) Unit
setTextCursor (TextCursor { before, selected, after }) element = do
    HTextArea.setValue (before <> selected <> after) element
    let start = length before
    let end = start + length selected
    HTextArea.setSelectionStart start element
    HTextArea.setSelectionEnd end element

tcValue :: TextCursor -> String
tcValue (TextCursor { before, selected, after }) = before <> selected <> after

select :: TextCursor
select = TextCursor
    { before: """arma virumque canō, Trōiae quī prīmus ab ōrīs"""
    , selected: "\n"
    , after: """Ītaliam fātō profugus Lāvīni͡aque vēnit"""
    }

normalize :: String -> String
normalize =
    replace (unsafeRegex "[\\s\\n]+\\n\\s*|\\s*\\n[\\s\\n]+" global) "\n"
    >>> replace (unsafeRegex "\\d+" global) ""
    >>> replace (unsafeRegex "'([^']+)'" global) "‘$1’"
    >>> replace (unsafeRegex "\"([^\"]+)\"" global) "“$1”"

ui :: forall eff. H.Component HH.HTML Query Unit Void (Aff (dom :: DOM | eff))
ui = H.component { render, eval, initialState: const initialState, receiver: const Nothing }
  where

  render :: UIState -> H.ComponentHTML Query
  render state =
    HH.div_
        [ HH.h2_/>"Pantheum: Scansion"
        , HH.div_ $ map display $ mklines state.simplify (tcValue state.text)
        , HH.br_
        , legend state.simplify
        , checkbox (HE.input_ ToggleState) [] "Simplify scansion marks" state.simplify
        , textarea (HE.input UserInput) [] "Text to scan" 5 (tcValue state.text)
        , HH.br_
        ]

  eval :: Query ~> H.ComponentDSL UIState Query Void (Aff (dom :: DOM | eff))
  eval (ToggleState next) = do
    H.modify (\state -> { simplify: not state.simplify, text: state.text })
    pure next
  eval (UserInput e next) = do
    let node = unsafeCoerce Event.target e :: HTMLTextAreaElement
    --s <- H.liftEff (HInput.value node :: Eff (dom :: DOM | eff) String)
    --let text = normalize s
    s <- H.liftEff $ textCursor node
    let text = case s of
            TextCursor { before, selected, after } -> TextCursor
                { before: normalize before
                , selected: normalize selected
                , after: normalize after
                }
    H.liftEff $ setTextCursor text node
    H.modify (\state -> { simplify: state.simplify, text })
    pure next

main :: Eff (HalogenEffects ()) Unit
main = runHalogenAff do
  body <- awaitBody
  runUI ui unit body

module Scansion where

import Prelude
import UIHelpers
import CSS as CSS
import CSS.Overflow as CSS.Overflow
import CSS.TextAlign as CSS.TextAlign
import DOM.Event.Event as Event
import DOM.HTML.HTMLInputElement as HInput
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import ArrayState (evalArrayState, evalReversedArrayState, sequence, sequenceReversed)
import CSS (CSS, StyleM, ex, fromHexString, nil)
import CSS.Common (auto)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.State (State)
import Control.Monad.State.Trans (get, put)
import Control.Plus (empty)
import DOM (DOM)
import DOM.Event.Types (Event)
import DOM.HTML.Types (HTMLInputElement)
import Data.Array (filter, mapWithIndex) as Array
import Data.Generic (class Generic, gCompare, gEq, gShow)
import Data.Int (odd)
import Data.Maybe (Maybe(..), fromJust, fromMaybe)
import Data.String (Pattern(..), indexOf, joinWith, trim)
import Data.String (split) as String
import Data.String.Regex (Regex, replace, split, test)
import Data.String.Regex.Flags (global, ignoreCase, noFlags)
import Data.String.Regex.Unsafe (unsafeRegex)
import Halogen.Aff (HalogenEffects)
import Halogen.Aff.Util (awaitBody, runHalogenAff)
import Halogen.HTML.CSS (style)
import Halogen.VDom.Driver (runUI)
import Partial.Unsafe (unsafePartial)
import Unsafe.Coerce (unsafeCoerce)

newtype Line =
    Line (Array Res)

instance showLine :: Show Line where
    show (Line line) = joinWith "" do
        res <- line
        pure case res of
            Punct s -> s
            Verb { syllables } ->
                joinWith "" do
                    Syllable { value, stype } <- syllables
                    --pure (value <> show stype)
                    pure value

class HalogenDisplay displayable where
    display :: forall a b. displayable -> HH.HTML a b

instance displayLine :: HalogenDisplay Line where
    display line_@(Line line) =
        HH.div_ [ scanned, raw ]
        where
            raw = HH.span [ style $ zindex 1 ] [ HH.text $ show line_ ]
            scanned = HH.div [ divstyle ] $ evalArrayState (map mapper line) 0.0
            divstyle = style do
                CSS.height (1.2#ex)
                zindex (-1)
                no_pointer_events
            mapper (Punct "\n") = pure HH.br_
            mapper (Punct s) = pure (spacer $ HH.text s)
            mapper (Verb { syllables, gloss }) =
                map HH.span_ $ sequence $ map displaySyllableColored syllables

y_mark :: forall a b. CSS -> HP.IProp ( style :: String | a ) b
y_mark extra =
    style do
        CSS.color (unsafePartial $ fromJust $ fromHexString "#F50057")
        CSS.Overflow.overflow CSS.Overflow.visible
        CSS.height (ex 1.0)
        scale 2.0 1.4
        no_user_select
        CSS.margin auto auto auto auto
        CSS.TextAlign.textAlign CSS.TextAlign.center
        extra

instance displaySyllable :: HalogenDisplay Syllable where
    display = displaySyllableStyled (CSS.height nil)

displaySyllableStyled :: forall a b. CSS -> Syllable -> HH.HTML a b
displaySyllableStyled extraStyle (Syllable { value, stype }) =
    HH.div
        [ style do
            CSS.display CSS.inlineBlock
        ]
        [ HH.div [ y_mark extraStyle ] [ HH.text $ show stype ]
        , spacer $ HH.text value
        ]

displaySyllableColored :: forall a b. Syllable -> State Number (HH.HTML a b)
displaySyllableColored syllable@(Syllable { value, stype }) = do
    position <- get
    let incr = case stype of
            Elided ->
                0.0

            Long ->
                1.0

            Ambiguous (Just a) | a ->
                1.0

            _ ->
                0.5
    put (position + incr)
    let clr =
            CSS.color $ fromMaybe (CSS.gray) $ CSS.fromHexString $
                case position of
                    0.0 ->
                        "#F50057"

                    2.0 ->
                        "#D500F9"

                    4.0 ->
                        "#651FFF"

                    6.0 ->
                        "#00E5FF"

                    8.0 ->
                        "#1DE9B6"

                    10.0 ->
                        "#00E676"

                    11.0 ->
                        "#2E7D32"

                    10.5 ->
                        "#FF3D00"

                    11.5 ->
                        "#FF3D00"

                    12.0 ->
                        "#FF3D00"

                    _ ->
                        ""
    pure $ displaySyllableStyled (clr) syllable

data Res
    = Punct String
    | Verb Word

type Word =
    { syllables :: Array Syllable
    , gloss :: String
    }

newtype Syllable = Syllable
    { value :: String
    , stype :: SyllableType
    }

data SyllableType
    = Long
    | Ambiguous (Maybe Boolean)
    | Short
    | Elided

instance showSyllableType :: Show SyllableType where
    show s =
        case s of
            Short ->
                "˘"

            Long ->
                "¯"

            Elided ->
                "˙"

            Ambiguous Nothing ->
                "˟"

            Ambiguous (Just b)
                | b -> "˜"
                | otherwise -> "ˇ"

startsWith :: Pattern -> String -> Boolean
startsWith p s = case indexOf p s of
    Just 0 -> true
    _ -> false

weight :: String -> ScanBias
weight syllable =
    if startsWith (Pattern "x") syllable || startsWith (Pattern "z") syllable then
        IntoDoubleConsonant
    else if test r_cx syllable then
        IntoConsonant
    else
        IntoVowel

data ScanBias = Elidable | IntoVowel | IntoConsonant | IntoDoubleConsonant | LineEnd
derive instance genericScanBias :: Generic ScanBias

instance showScanBias :: Show ScanBias where
  show = gShow

instance eqScanBias :: Eq ScanBias where
  eq = gEq

instance ordScanBias :: Ord ScanBias where
  compare = gCompare

reform :: Syllable -> ScanBias -> SyllableType
reform _ IntoDoubleConsonant = Long
reform (Syllable {stype: Ambiguous _}) LineEnd = Long
reform (Syllable {stype: Short}) LineEnd = Ambiguous Nothing
reform (Syllable {value}) Elidable
    | test r_elision value = Elided
reform (Syllable {stype: Ambiguous Nothing}) IntoVowel = Ambiguous (Just false)
reform (Syllable {stype: Ambiguous Nothing}) Elidable = Ambiguous (Just false)
reform (Syllable {stype: Ambiguous Nothing}) IntoConsonant = Ambiguous (Just true)
reform (Syllable {stype}) _ = stype

resimplify :: Boolean -> SyllableType -> SyllableType
resimplify true (Ambiguous (Just false)) = Short
resimplify true (Ambiguous (Just true)) = Long
resimplify _ stype = stype

inner :: Boolean -> Syllable -> State ScanBias Syllable
inner simplify syllable@(Syllable {value}) = do
    bias <- get
    put (weight value)
    let stype = resimplify simplify $ reform syllable bias
    pure (Syllable { value, stype })

middle :: Boolean -> Array Syllable -> State ScanBias (Array Syllable)
middle simplify syllables = sequenceReversed $ map (inner simplify) syllables

outer :: Boolean -> Res -> State ScanBias Res
outer simplify (Verb w) = do
    bias <- get
    case bias of
        IntoVowel -> put Elidable
        -- double consonants do not affect preceding word in scansion
        IntoDoubleConsonant -> put IntoConsonant
        _ -> pure unit
    syllables <- middle simplify w.syllables
    pure $ Verb { syllables, gloss: w.gloss }
outer _ (res@Punct "\n") = do
    put LineEnd
    pure res
outer _ res = pure res

rescan :: Boolean -> Line -> Line
rescan simplify (Line line) = Line rescanned
    where
        rescanned = evalReversedArrayState statecomputation LineEnd
        statecomputation = map (outer simplify) line

v :: String
v =
    "(?:[aeiouy]͡[aeiouyāēīōūȳ]̄?|(?:a[eu]|oe|eu)(?![̄̈])|[aeiouyāēīōūȳ]̄?|[aeiouy]̄|[äëïöüÿ])"

c :: String
c =
    "(?:[qg]u(?=" <> v <> ")|[ck]h|[bcdfghjklmnprstvwxz]|\\bi(?=" <> v <> "))"

l :: String
l =
    "(?:" <> c <> "|" <> v <> ")"

r_word :: Regex
r_word =
    unsafeRegex ("((?:" <> c <> "|" <> v <> ")+)") (ignoreCase <> global)

r_syllable :: Regex
r_syllable =
    unsafeRegex (c <> "*" <> v <> "(" <> c <> "*$|(?![dbpckgt][rl])" <> c <> "((?=" <> c <> "+" <> v <> "?))" <> ")?") (ignoreCase <> global)

r_short :: Regex
r_short =
    unsafeRegex ("(\\bi?|[^aeiouy]|[qg]u)[aeiouy]$") ignoreCase

r_long :: Regex
r_long =
    unsafeRegex ("[aeiouy]̄|[āēīōūȳ]|a[eu]|oe|eu|(x|z|" <> c <> c <> ")$") ignoreCase

r_cx :: Regex
r_cx =
    unsafeRegex ("^((?!h)" <> c <> "|[ij]" <> v <> "|[aeiouy]̄|[äëïöüÿ])") ignoreCase

r_elision :: Regex
r_elision =
    unsafeRegex (v <> "m?$") ignoreCase

r_wordbreak :: Regex
r_wordbreak =
    unsafeRegex ("(?:(?:^|" <> l <> ")" <> l <> "*(?=))") ignoreCase

foreign import _findall :: Regex -> String -> Array String

mksyllables :: String -> Array Syllable
mksyllables content =
    content # _findall r_syllable # map mksyllable
    --content # Regex.find Regex.All r_syllable # map (_.match >>> syllable)
    --content # Regex.match r_syllable # fromMaybe [] # map (_.match >>> syllable)

mksyllable :: String -> Syllable
mksyllable s = Syllable
    { value: s
    , stype:
        if test r_short s then
            Short
        else if test r_long s then
            Long
        else
            Ambiguous Nothing
    }

mkline :: Boolean -> String -> Line
mkline simplify content =
    content # mkwords # Array.filter nonempty # Line # rescan simplify
    where
        nonempty (Punct "") = false
        nonempty (Verb { syllables: [] }) = false
        nonempty _ = true

mklines :: Boolean -> String -> Array Line
mklines simplify content =
    trim content # String.split (Pattern "\n") # map (trim >>> mkline simplify)

processtext :: (String -> Res) -> (String -> Res) -> String -> Array Res
processtext mkverb mkpunct =
    let
        mapper i
            | odd i = mkverb
            | otherwise = mkpunct
    in
        Array.mapWithIndex mapper <<< split r_word

mkwords :: String -> Array Res
mkwords content =
    --content # split r_word # map (\s -> Verb { syllables: mksyllables s, gloss: s})
    processtext (\s -> Verb $ { syllables: mksyllables s, gloss: s }) Punct content

data Query a
    = ToggleState a
    | UserInput Event a

type UIState =
    { simplify :: Boolean
    , text :: String
    }

initialState :: UIState
initialState =
    { simplify: true
    , text: """arma virumque canō, Trōiae quī prīmus ab ōrīs
Ītaliam fātō profugus Lāvīni͡aque vēnit"""
    }

legend :: forall a b. Boolean -> HH.HTML a b
legend true =
    HH.div_/>"¯ a long (heavy) syllable, ˘ a short syllable"
legend false =
    HH.div_/>"¯ a long (heavy) syllable, ˜ a syllable long by position, ˇ a syllable short by position, ˘ a short syllable"

ui :: forall eff. H.Component HH.HTML Query Unit Void (Aff (dom :: DOM | eff))
ui = H.component { render, eval, initialState: const initialState, receiver: const Nothing }
  where

  render :: UIState -> H.ComponentHTML Query
  render state =
    HH.div_
        [ HH.h2_/>"Pantheum: Scansion"
        , HH.div_ $ map display $ mklines state.simplify state.text
        , HH.br_
        , legend state.simplify
        , checkbox (HE.input_ ToggleState) [] "Simplify scansion marks" state.simplify
        , textarea (HE.input UserInput) [] "Text to scan" 5 state.text
        , HH.br_
        ]

  eval :: Query ~> H.ComponentDSL UIState Query Void (Aff (dom :: DOM | eff))
  eval (ToggleState next) = do
    H.modify (\state -> { simplify: not state.simplify, text: state.text })
    pure next
  eval (UserInput e next) = do
    let node = unsafeCoerce Event.target e :: HTMLInputElement
    s <- H.liftEff (HInput.value node :: Eff (dom :: DOM | eff) String)
    let text = s
            # replace (unsafeRegex "[\\s\\n]+\\n\\s*|\\s*\\n[\\s\\n]+" global) "\n"
            # replace (unsafeRegex "\\d+" global) ""
            # replace (unsafeRegex "'([^']+)'" global) "‘$1’"
            # replace (unsafeRegex "\"([^\"]+)\"" global) "“$1”"
    H.modify (\state -> { simplify: state.simplify, text })
    pure next

main :: Eff (HalogenEffects ()) Unit
main = runHalogenAff do
  body <- awaitBody
  runUI ui unit body


remove trailing spaces.

remove trailing spaces.

-- | This module defines functions for working with React components at a high level:
-- |
-- | - `createClass` and `simpleSpec`, which can be used to create a component class
-- | - `render` and `renderTo`, which can be used to render a component class

module Thermite
  ( PerformAction()
  , Render()
  , Spec()
  , SpecRecord()
  , simpleSpec
  , componentWillMount
  , createClass
  , displayName
  , render
  , renderTo
  ) where

import Prelude

import DOM
import DOM.Node.Types

import Data.Maybe

import Control.Monad.Eff

import Thermite.Html
import Thermite.Internal
import Thermite.Types
import Thermite.Action

-- | A type synonym for action handlers, which take an action and the current properties
-- | for the component, and return a computation in the `Action` monad.
type PerformAction eff state props action = props -> action -> Action eff state Unit

-- | A rendering function, which takes a `Context`, the current state and properties, an array
-- | of child nodes and returns a HTML document.
type Render eff state props action = Context state action -> state -> props -> Array (Html eff) -> Html eff

-- | A component specification, which can be passed to `createClass`.
-- |
-- | A minimal `Spec` can be built using `simpleSpec`, and extended with optional arguments
-- | using functions in the `Thermite` module.
newtype Spec eff state props action = Spec (SpecRecord eff state props action)

-- | A type synonym for the record type which captures the functions which make up a `Spec`.
type SpecRecord eff state props action =
  { initialState       :: state
  , performAction      :: PerformAction eff state props action
  , render             :: Render eff state props action
  , componentWillMount :: Maybe action
  , displayName        :: Maybe String
  }

-- | Create a minimal `Spec`. The arguments are, in order:
-- |
-- | - The initial component state
-- | - A function for performing actions
-- | - A function for rendering the current state as a HTML document
-- |
-- | A `Spec` created using this function can be extended with optional properties using other functions
-- | in this module.
simpleSpec :: forall eff state props action.
                state ->
                PerformAction eff state props action ->
                Render eff state props action ->
                Spec eff state props action
simpleSpec initialState performAction render = Spec { initialState: initialState
                                                    , performAction: performAction
                                                    , render: render
                                                    , componentWillMount: Nothing
                                                    , displayName: Nothing
                                                    }

-- | Extend a `Spec` with an action to run when the component will be mounted.
componentWillMount :: forall eff state props action. action -> Spec eff state props action -> Spec eff state props action
componentWillMount action (Spec spec) = Spec (spec { componentWillMount = Just action })

-- | Extend a `Spec` with a display name.
displayName :: forall eff state props action. String -> Spec eff state props action -> Spec eff state props action
displayName name (Spec spec) = Spec (spec { displayName = Just name })

foreign import createClassImpl :: forall eff state props action.
  (Context state action -> Action eff state Unit -> Eff eff Unit) ->
  (forall a r. r -> (a -> r) -> Maybe a -> r) ->
  Spec eff state props action ->
  ComponentClass props eff

-- | Create a component class from a `Spec`.
createClass :: forall eff state props action. Spec eff state props action -> ComponentClass props eff
createClass = createClassImpl runAction maybe

-- | Render a component class to the document body.
render :: forall props eff. ComponentClass props eff -> props -> Eff (dom :: DOM | eff) Unit
render cc props = do
  body <- documentBody
  renderTo body cc props

-- | Render a component class to the specified node.
renderTo :: forall props eff. Node -> ComponentClass props eff -> props -> Eff (dom :: DOM | eff) Unit
renderTo = renderToImpl