restore comments from Routing.Match.Class

module Routing.Match where

import Prelude

import Control.Alt (class Alt, (<|>))
import Control.Alternative (class Alternative)
import Control.Plus (class Plus)
import Data.Either (Either(..))
import Data.Foldable (foldl)
import Data.Int (fromString)
import Data.List (List(..), reverse)
import Data.Map as M
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (class Newtype, unwrap)
import Data.Semiring.Free (Free, free)
import Data.String.NonEmpty (NonEmptyString)
import Data.String.NonEmpty as NES
import Data.Tuple (Tuple(..), snd)
import Data.Validation.Semiring (V, invalid, unV)
import Global (readFloat, isNaN)
import Routing.Match.Error (MatchError(..), showMatchError)
import Routing.Types (Route, RoutePart(..))

newtype Match a = Match (Route -> V (Free MatchError) (Tuple Route a))

-- Manual instance due to the `Route` synonym in the above
instance newtypeMatch :: Newtype (Match a) (List RoutePart -> V (Free MatchError) (Tuple (List RoutePart) a)) where
  wrap = Match
  unwrap (Match m) = m

instance matchFunctor :: Functor Match where
  map fn (Match r2e) = Match $ \r ->
    unV invalid (\(Tuple rs a) -> pure $ Tuple rs (fn a)) $ r2e r

instance matchAlt :: Alt Match where
  alt (Match r2e1) (Match r2e2) = Match $ \r -> do
    (r2e1 r) <|> (r2e2 r)

instance matchPlus :: Plus Match where
  empty = Match $ const $ invalid one

instance matchAlternative :: Alternative Match

instance matchApply :: Apply Match where
  apply (Match r2a2b) (Match r2a) =
    Match $ (\r -> unV (processFnErr r) processFnRes (r2a2b r))
    where processFnErr r err =
            invalid $ err * unV identity (const one) (r2a r)
          processFnRes (Tuple rs a2b) =
            unV invalid (\(Tuple rss a) -> pure $ Tuple rss (a2b a)) (r2a rs)

instance matchApplicative :: Applicative Match where
  pure a = Match \r -> pure $ Tuple r a

-- | Matches a leading slash.
root :: Match Unit
root = lit ""

-- | `lit x` will match exactly the path component `x`.
-- | For example, `lit "x"` matches `/x`.
lit :: String -> Match Unit
lit input = Match \route ->
  case route of
    Cons (Path i) rs | i == input ->
      pure $ Tuple rs unit
    Cons (Path _) rs ->
      invalid $ free $  UnexpectedPath input
    _ ->
      invalid $ free ExpectedPathPart

-- | `num` matches any numerical path component.
num :: Match Number
num = Match \route ->
  case route of
    Cons (Path input) rs ->
      let res = readFloat input in
      if isNaN res then
        invalid $ free ExpectedNumber
      else
        pure $ Tuple rs res
    _ ->
      invalid $ free ExpectedNumber

-- | `int` matches any integer path component.
int :: Match Int
int = Match \route ->
  case route of
    Cons (Path input) rs -> case fromString input of
      Nothing -> invalid $ free ExpectedInt
      Just res -> pure $ Tuple rs res
    _ ->
      invalid $ free ExpectedInt

-- | `bool` matches any boolean path component.
bool :: Match Boolean
bool = Match \route ->
  case route of
    Cons (Path input) rs | input == "true" ->
      pure $ Tuple rs true
    Cons (Path input) rs | input == "false" ->
      pure $ Tuple rs false
    _ ->
      invalid $ free ExpectedBoolean

-- | `str` matches any path string component.
-- | For example, `str` matches `/foo` as `"foo"`.
str :: Match String
str = Match \route ->
  case route of
    Cons (Path input) rs ->
      pure $ Tuple rs input
    _ ->
      invalid $ free ExpectedString

-- | `param p` matches a parameter assignment `q=v` within a query block.
-- | For example, `param "q"` matches `/?q=a&r=b` as `"a"`.
param :: String -> Match String
param key = Match \route ->
  case route of
    Cons (Query map) rs ->
      case M.lookup key map of
        Nothing ->
          invalid $ free $ KeyNotFound key
        Just el ->
          pure $ Tuple (Cons (Query <<< M.delete key $ map) rs) el
    _ ->
      invalid $ free ExpectedQuery

-- | `params` matches an entire query block. For exmaple, `params`
-- | matches `/?q=a&r=b` as the map `{q : "a", r : "b"}`. Note that
-- | `lit "foo" *> params` does *not* match `/foo`, since a query component
-- | is *required*.
params :: Match (M.Map String String)
params = Match \route ->
  case route of
    Cons (Query map) rs ->
      pure $ Tuple rs map
    _ ->
      invalid $ free ExpectedQuery

-- | `end` matches the end of a route.
end :: Match Unit
end = Match \route ->
  case route of
    Nil -> pure $ Tuple Nil unit
    _ -> invalid $ free ExpectedEnd

fail :: forall a. String -> Match a
fail msg = Match \_ ->
  invalid $ free $ Fail msg

-- | Matches a non-empty string.
nonempty :: Match NonEmptyString
nonempty =
  eitherMatch $ maybe (Left "Empty string") Right <<< NES.fromString <$> str

-- | Matches list of matchers. Useful when argument can easy fail (not `str`)
-- | returns `Match Nil` if no matches
list :: forall a. Match a -> Match (List a)
list (Match r2a) =
  Match $ go Nil
  where go :: List a -> Route -> V (Free MatchError) (Tuple Route (List a))
        go accum r =
          unV
          (const $ pure (Tuple r (reverse accum)))
          (\(Tuple rs a) -> go (Cons a accum) rs)
          (r2a r)

-- It groups `Free MatchError` -> [[MatchError]] -map with showMatchError ->
-- [[String]] -fold with semicolon-> [String] -fold with newline-> String
runMatch :: forall a. Match a -> Route -> Either String a
runMatch (Match fn) route =
  unV foldErrors (Right <<< snd) $ fn route
  where
  foldErrors errs =
    Left $ foldl (\b a -> a <> "\n" <> b) "" do
      es <- reverse <$> unwrap errs
      pure $ foldl (\b a -> a <> ";" <> b) "" $ showMatchError <$>  es

-- | if we match something that can fail then we have to
-- | match `Either a b`. This function converts matching on such
-- | sum to matching on right subpart. Matching on left branch fails.
-- | i.e.
-- | ```purescript
-- | data Sort = Asc | Desc
-- | sortOfString :: String -> Either String Sort
-- | sortOfString "asc" = Right Asc
-- | sortOfString "desc" = Right Desc
-- | sortOfString _ = Left "incorrect sort"
-- |
-- | newtype Routing = Routing Sort
-- | routes :: Match Routing
-- | routes = (pure Routing) <*> (eitherMatch (sortOfString <$> var))
-- |
-- | ```
eitherMatch :: forall a b. Match (Either a b) -> Match b
eitherMatch (Match r2eab) = Match $ \r ->
  unV invalid runEither $ (r2eab r)
  where
  runEither (Tuple rs eit) =
    case eit of
      Left _ -> invalid $ free $ Fail "Nested check failed"
      Right res -> pure $ Tuple rs res

-- | useful for matching optional params at the end of a path
-- | ```
-- | optParams = maybe M.empty id <$> optionalMatch params <* end
-- | runMatch (lit "path" *> optParams) (parse id "path/?a=1")
-- | -- (Right (fromFoldable [(Tuple "a" "1")]))
-- | ```
optionalMatch :: forall a. Match a -> Match (Maybe a)
optionalMatch (Match fn) = Match (\route -> unV (const $ pure (Tuple route Nothing)) (pure <<< map Just) $ fn route)

module Routing.Match where

import Prelude

import Control.Alt (class Alt, (<|>))
import Control.Alternative (class Alternative)
import Control.Plus (class Plus)
import Data.Either (Either(..))
import Data.Foldable (foldl)
import Data.Int (fromString)
import Data.List (List(..), reverse)
import Data.Map as M
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (class Newtype, unwrap)
import Data.Semiring.Free (Free, free)
import Data.String.NonEmpty (NonEmptyString)
import Data.String.NonEmpty as NES
import Data.Tuple (Tuple(..), snd)
import Data.Validation.Semiring (V, invalid, unV)
import Global (readFloat, isNaN)
import Routing.Match.Error (MatchError(..), showMatchError)
import Routing.Types (Route, RoutePart(..))

newtype Match a = Match (Route -> V (Free MatchError) (Tuple Route a))

-- Manual instance due to the `Route` synonym in the above
instance newtypeMatch :: Newtype (Match a) (List RoutePart -> V (Free MatchError) (Tuple (List RoutePart) a)) where
  wrap = Match
  unwrap (Match m) = m

instance matchFunctor :: Functor Match where
  map fn (Match r2e) = Match $ \r ->
    unV invalid (\(Tuple rs a) -> pure $ Tuple rs (fn a)) $ r2e r

instance matchAlt :: Alt Match where
  alt (Match r2e1) (Match r2e2) = Match $ \r -> do
    (r2e1 r) <|> (r2e2 r)

instance matchPlus :: Plus Match where
  empty = Match $ const $ invalid one

instance matchAlternative :: Alternative Match

instance matchApply :: Apply Match where
  apply (Match r2a2b) (Match r2a) =
    Match $ (\r -> unV (processFnErr r) processFnRes (r2a2b r))
    where processFnErr r err =
            invalid $ err * unV identity (const one) (r2a r)
          processFnRes (Tuple rs a2b) =
            unV invalid (\(Tuple rss a) -> pure $ Tuple rss (a2b a)) (r2a rs)

instance matchApplicative :: Applicative Match where
  pure a = Match \r -> pure $ Tuple r a

-- | Matches a leading slash.
root :: Match Unit
root = lit ""

lit :: String -> Match Unit
lit input = Match \route ->
  case route of
    Cons (Path i) rs | i == input ->
      pure $ Tuple rs unit
    Cons (Path _) rs ->
      invalid $ free $  UnexpectedPath input
    _ ->
      invalid $ free ExpectedPathPart

num :: Match Number
num = Match \route ->
  case route of
    Cons (Path input) rs ->
      let res = readFloat input in
      if isNaN res then
        invalid $ free ExpectedNumber
      else
        pure $ Tuple rs res
    _ ->
      invalid $ free ExpectedNumber

int :: Match Int
int = Match \route ->
  case route of
    Cons (Path input) rs -> case fromString input of
      Nothing -> invalid $ free ExpectedInt
      Just res -> pure $ Tuple rs res
    _ ->
      invalid $ free ExpectedInt

bool :: Match Boolean
bool = Match \route ->
  case route of
    Cons (Path input) rs | input == "true" ->
      pure $ Tuple rs true
    Cons (Path input) rs | input == "false" ->
      pure $ Tuple rs false
    _ ->
      invalid $ free ExpectedBoolean

str :: Match String
str = Match \route ->
  case route of
    Cons (Path input) rs ->
      pure $ Tuple rs input
    _ ->
      invalid $ free ExpectedString

param :: String -> Match String
param key = Match \route ->
  case route of
    Cons (Query map) rs ->
      case M.lookup key map of
        Nothing ->
          invalid $ free $ KeyNotFound key
        Just el ->
          pure $ Tuple (Cons (Query <<< M.delete key $ map) rs) el
    _ ->
      invalid $ free ExpectedQuery

params :: Match (M.Map String String)
params = Match \route ->
  case route of
    Cons (Query map) rs ->
      pure $ Tuple rs map
    _ ->
      invalid $ free ExpectedQuery

end :: Match Unit
end = Match \route ->
  case route of
    Nil -> pure $ Tuple Nil unit
    _ -> invalid $ free ExpectedEnd

fail :: forall a. String -> Match a
fail msg = Match \_ ->
  invalid $ free $ Fail msg

-- | Matches a non-empty string.
nonempty :: Match NonEmptyString
nonempty =
  eitherMatch $ maybe (Left "Empty string") Right <<< NES.fromString <$> str

-- | Matches list of matchers. Useful when argument can easy fail (not `str`)
-- | returns `Match Nil` if no matches
list :: forall a. Match a -> Match (List a)
list (Match r2a) =
  Match $ go Nil
  where go :: List a -> Route -> V (Free MatchError) (Tuple Route (List a))
        go accum r =
          unV
          (const $ pure (Tuple r (reverse accum)))
          (\(Tuple rs a) -> go (Cons a accum) rs)
          (r2a r)

-- It groups `Free MatchError` -> [[MatchError]] -map with showMatchError ->
-- [[String]] -fold with semicolon-> [String] -fold with newline-> String
runMatch :: forall a. Match a -> Route -> Either String a
runMatch (Match fn) route =
  unV foldErrors (Right <<< snd) $ fn route
  where
  foldErrors errs =
    Left $ foldl (\b a -> a <> "\n" <> b) "" do
      es <- reverse <$> unwrap errs
      pure $ foldl (\b a -> a <> ";" <> b) "" $ showMatchError <$>  es

-- | if we match something that can fail then we have to
-- | match `Either a b`. This function converts matching on such
-- | sum to matching on right subpart. Matching on left branch fails.
-- | i.e.
-- | ```purescript
-- | data Sort = Asc | Desc
-- | sortOfString :: String -> Either String Sort
-- | sortOfString "asc" = Right Asc
-- | sortOfString "desc" = Right Desc
-- | sortOfString _ = Left "incorrect sort"
-- |
-- | newtype Routing = Routing Sort
-- | routes :: Match Routing
-- | routes = (pure Routing) <*> (eitherMatch (sortOfString <$> var))
-- |
-- | ```
eitherMatch :: forall a b. Match (Either a b) -> Match b
eitherMatch (Match r2eab) = Match $ \r ->
  unV invalid runEither $ (r2eab r)
  where
  runEither (Tuple rs eit) =
    case eit of
      Left _ -> invalid $ free $ Fail "Nested check failed"
      Right res -> pure $ Tuple rs res

-- | useful for matching optional params at the end of a path
-- | ```
-- | optParams = maybe M.empty id <$> optionalMatch params <* end
-- | runMatch (lit "path" *> optParams) (parse id "path/?a=1")
-- | -- (Right (fromFoldable [(Tuple "a" "1")]))
-- | ```
optionalMatch :: forall a. Match a -> Match (Maybe a)
optionalMatch (Match fn) = Match (\route -> unV (const $ pure (Tuple route Nothing)) (pure <<< map Just) $ fn route)


Don't allow format characters in C# identifiers

They are technically allowed, but some of them are
non-breaking spaces which the C# compiler considers
equivalent (maybe even ignores?), but which our string
comparison doesn't consider equal, so we'll end up with
different C# properties that are duplicates to the C#
compiler.

module Language.CSharp
    ( renderer
    ) where

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 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.Tuple (Tuple(..))
import Data.String.Util (camelCase, legalizeCharacters, startWithLetter, stringEscape, isLetterOrLetterNumber)
import Options (enumOption, Option)

forbiddenNames :: Array String
forbiddenNames = ["Convert", "JsonConverter", "Type"]

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
    IRAnything -> 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

getDecoderHelperPrefix :: String -> Doc String
getDecoderHelperPrefix topLevelName = getForSingleOrMultipleTopLevels "" topLevelName

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 <> ":"
    forEachTopLevel_ \topLevelName topLevelType -> do
        prefix <- getDecoderHelperPrefix topLevelName
        line "//"
        line $ "//    var data = " <> module_ <> ".Convert." <> prefix <> "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)
        blank
        renderJsonConverter
    line "}"

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

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

renderJsonConverter :: Doc Unit
renderJsonConverter = do
    unionNames <- getUnionNames
    let haveUnions = not $ M.isEmpty unionNames
    let names = M.values unionNames
    line $ "public class Convert" <> stringIfTrue haveUnions " : JsonConverter"
    line "{"
    indent do
        line "// Serialize/deserialize helpers"
        forEachTopLevel_ \topLevelName topLevelType -> do
            blank
            topLevelTypeRendered <- renderTypeToCSharp topLevelType
            fromJsonPrefix <- getDecoderHelperPrefix topLevelName
            line
                $ "public static "
                <> topLevelTypeRendered
                <> " "
                <> fromJsonPrefix
                <> "FromJson(string json) => JsonConvert.DeserializeObject<"
                <> topLevelTypeRendered
                <> ">(json, Settings);"
            whenSerializers do
                line
                    $ "public static string ToJson("
                    <> topLevelTypeRendered
                    <> " o) => JsonConvert.SerializeObject(o, Settings);"

        blank
        line "// JsonConverter stuff"

        when haveUnions do
            blank
            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 "static JsonSerializerSettings Settings = new JsonSerializerSettings"
        line "{"
        indent do
            line "MetadataPropertyHandling = MetadataPropertyHandling.Ignore,"
            line "DateParseHandling = DateParseHandling.None,"
            when haveUnions do
                line "Converters = { new Convert() },"
        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 struct " <> name
    line "{"
    indent do
        forUnion_ nonNullUnion \t -> do
            typeString <- renderNullableToCSharp t
            field <- unionFieldName t
            line $ "public " <> typeString <> " " <> field <> ";"
        blank
        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 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 "}"

module Language.CSharp
    ( renderer
    ) where

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 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.Tuple (Tuple(..))
import Data.String.Util (camelCase, legalizeCharacters, startWithLetter, stringEscape, isLetterOrLetterNumber)
import Options (enumOption, Option)

forbiddenNames :: Array String
forbiddenNames = ["Convert", "JsonConverter", "Type"]

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
    Just Format -> 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
    IRAnything -> 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

getDecoderHelperPrefix :: String -> Doc String
getDecoderHelperPrefix topLevelName = getForSingleOrMultipleTopLevels "" topLevelName

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 <> ":"
    forEachTopLevel_ \topLevelName topLevelType -> do
        prefix <- getDecoderHelperPrefix topLevelName
        line "//"
        line $ "//    var data = " <> module_ <> ".Convert." <> prefix <> "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)
        blank
        renderJsonConverter
    line "}"

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

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

renderJsonConverter :: Doc Unit
renderJsonConverter = do
    unionNames <- getUnionNames
    let haveUnions = not $ M.isEmpty unionNames
    let names = M.values unionNames
    line $ "public class Convert" <> stringIfTrue haveUnions " : JsonConverter"
    line "{"
    indent do
        line "// Serialize/deserialize helpers"
        forEachTopLevel_ \topLevelName topLevelType -> do
            blank
            topLevelTypeRendered <- renderTypeToCSharp topLevelType
            fromJsonPrefix <- getDecoderHelperPrefix topLevelName
            line
                $ "public static "
                <> topLevelTypeRendered
                <> " "
                <> fromJsonPrefix
                <> "FromJson(string json) => JsonConvert.DeserializeObject<"
                <> topLevelTypeRendered
                <> ">(json, Settings);"
            whenSerializers do
                line
                    $ "public static string ToJson("
                    <> topLevelTypeRendered
                    <> " o) => JsonConvert.SerializeObject(o, Settings);"

        blank
        line "// JsonConverter stuff"

        when haveUnions do
            blank
            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 "static JsonSerializerSettings Settings = new JsonSerializerSettings"
        line "{"
        indent do
            line "MetadataPropertyHandling = MetadataPropertyHandling.Ignore,"
            line "DateParseHandling = DateParseHandling.None,"
            when haveUnions do
                line "Converters = { new Convert() },"
        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 struct " <> name
    line "{"
    indent do
        forUnion_ nonNullUnion \t -> do
            typeString <- renderNullableToCSharp t
            field <- unionFieldName t
            line $ "public " <> typeString <> " " <> field <> ";"
        blank
        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 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 "}"


Add `quickCheckGen` and variants

Add `quickCheckGen` and variants

-- | 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
  , quickCheckGen
  , quickCheck'
  , quickCheckGen'
  , quickCheckWithSeed
  , quickCheckGenWithSeed
  , quickCheckPure
  , quickCheckGenPure
  , class Testable
  , test
  , Result(..)
  , withHelp
  , (<?>)
  , assertEquals
  , (===)
  , (==?)
  , assertNotEquals
  , (/==)
  , (/=?)
  , assertLessThan
  , (<?)
  , assertLessThanEq
  , (<=?)
  , assertGreaterThan
  , (>?)
  , assertGreaterThanEq
  , (>=?)
  , 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, exception :: 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 version of `quickCheck` with the property specialized to `Gen`.
-- |
-- | The `quickCheckGen` variants are useful for writing property tests where a
-- | `MonadGen` constraint (or QuickCheck's `Gen` directly) is being used,
-- | rather than relying on `Arbitrary` instances. Especially useful for the
-- | `MonadGen`-constrained properties as they will not infer correctly when
-- | used with the `quickCheck` functions unless an explicit type annotation is
-- | used.
quickCheckGen :: forall eff prop. Testable prop => Gen prop -> QC eff Unit
quickCheckGen = quickCheck

-- | 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 version of `quickCheck'` with the property specialized to `Gen`.
quickCheckGen' :: forall eff prop. Testable prop => Int -> Gen prop -> QC eff Unit
quickCheckGen' = quickCheck'

-- | 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 initialSeed n prop = do
  let result = tailRec loop { seed: initialSeed, 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 })
              }

-- | A version of `quickCheckWithSeed` with the property specialized to `Gen`.
quickCheckGenWithSeed :: forall eff prop. Testable prop => Seed -> Int -> Gen prop -> QC eff Unit
quickCheckGenWithSeed = quickCheckWithSeed

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

-- | Test a property, returning all test results as a List.
-- |
-- | 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 }

-- | A version of `quickCheckPure` with the property specialized to `Gen`.
quickCheckGenPure :: forall prop. Testable prop => Seed -> Int -> Gen prop -> List Result
quickCheckGenPure = quickCheckPure

-- | 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 comparison operation
assertOp :: forall a. Eq a => Show a => (a -> a -> Boolean) -> String -> a -> a -> Result
assertOp op failString a b = a `op` b <?> show a <> failString <> show b

-- | Self-documenting equality assertion
assertEquals :: forall a. Eq a => Show a => a -> a -> Result
assertEquals = assertOp (==) " /= "

infix 2 assertEquals as ===
infix 2 assertEquals as ==?

-- | Self-documenting inequality assertion
assertNotEquals :: forall a. Eq a => Show a => a -> a -> Result
assertNotEquals = assertOp (/=) " == "

infix 2 assertNotEquals as /==
infix 2 assertNotEquals as /=?

assertLessThan :: forall a. Ord a => Show a => a -> a -> Result
assertLessThan = assertOp (<) " >= "

infix 2 assertLessThan as <?

assertLessThanEq :: forall a. Ord a => Show a => a -> a -> Result
assertLessThanEq = assertOp (<=) " > "

infix 2 assertLessThanEq as <=?

assertGreaterThan :: forall a. Ord a => Show a => a -> a -> Result
assertGreaterThan = assertOp (>) " <= "

infix 2 assertGreaterThan as >?

assertGreaterThanEq :: forall a. Ord a => Show a => a -> a -> Result
assertGreaterThanEq = assertOp (>=) " < "

infix 2 assertGreaterThanEq 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
  , (/==)
  , (/=?)
  , assertLessThan
  , (<?)
  , assertLessThanEq
  , (<=?)
  , assertGreaterThan
  , (>?)
  , assertGreaterThanEq
  , (>=?)
  , 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, exception :: 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 initialSeed n prop = do
  let result = tailRec loop { seed: initialSeed, 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 a List.
-- |
-- | 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 comparison operation
assertOp :: forall a. Eq a => Show a => (a -> a -> Boolean) -> String -> a -> a -> Result
assertOp op failString a b = a `op` b <?> show a <> failString <> show b

-- | Self-documenting equality assertion
assertEquals :: forall a. Eq a => Show a => a -> a -> Result
assertEquals = assertOp (==) " /= "

infix 2 assertEquals as ===
infix 2 assertEquals as ==?

-- | Self-documenting inequality assertion
assertNotEquals :: forall a. Eq a => Show a => a -> a -> Result
assertNotEquals = assertOp (/=) " == "

infix 2 assertNotEquals as /==
infix 2 assertNotEquals as /=?

assertLessThan :: forall a. Ord a => Show a => a -> a -> Result
assertLessThan = assertOp (<) " >= "

infix 2 assertLessThan as <?

assertLessThanEq :: forall a. Ord a => Show a => a -> a -> Result
assertLessThanEq = assertOp (<=) " > "

infix 2 assertLessThanEq as <=?

assertGreaterThan :: forall a. Ord a => Show a => a -> a -> Result
assertGreaterThan = assertOp (>) " <= "

infix 2 assertGreaterThan as >?

assertGreaterThanEq :: forall a. Ord a => Show a => a -> a -> Result
assertGreaterThanEq = assertOp (>=) " < "

infix 2 assertGreaterThanEq as >=?


Infix notation for functions

Infix notation for functions

Added infix notation for functions example: max 1 3 <=> 1 `max` 3

module Parser where

import Prelude (Unit, bind, return, ($), (<$>), (<<<), unit, (++), void, id, flip, negate, liftM1)
import Global (readInt)
import Data.String as String
import Data.Int (floor)
import Data.List (List(Cons), many, toList, concat, elemIndex, fromList)
import Data.Maybe (Maybe(..), maybe)
import Data.Tuple.Nested (Tuple3, uncurry3, tuple3)
import Data.Array (modifyAt, snoc)

import Control.Alt ((<|>))
import Control.Apply ((<*), (*>))
import Control.Lazy (fix)
import Data.Identity (Identity)
import Data.Either (Either)

import Text.Parsing.Parser (ParseError, Parser, runParser, fail)
import Text.Parsing.Parser.Combinators as PC
import Text.Parsing.Parser.Expr (OperatorTable, Assoc(AssocRight, AssocNone, AssocLeft), Operator(Infix, Prefix), buildExprParser)
import Text.Parsing.Parser.String (whiteSpace, char, string, oneOf, noneOf, skipSpaces)

--Purescript 0.8+ required
import Text.Parsing.Parser.Token
import Text.Parsing.Parser.Language (haskellDef)

import AST (Atom(..), Binding(..), Definition(Def), Expr(..), Op(..), pPrintOp)

---------------------------------------------------------
-- Use Haskell Language Definition --new purescript-parsing 0.8+
---------------------------------------------------------

tokenParser :: TokenParser
tokenParser = makeTokenParser haskellDef

---------------------------------------------------------
-- Parsers for Atoms
---------------------------------------------------------

-- | Skip spaces and tabs
eatSpaces :: Parser String Unit
eatSpaces = void $ many $ oneOf [' ','\t']
--eatSpaces = skipSpaces

anyDigit :: Parser String Char
anyDigit = digit

-- | Parser for Int. (0 to 2^31-1)
int :: Parser String Atom
int = AInt <$> tokenParser.decimal

-- | Parser for Boolean
bool :: Parser String Atom
bool = string "True"  *> return (Bool true)
   <|> string "False" *> return (Bool false)

-- | Parser for characters at the start of variables
lowerCaseLetter :: Parser String Char
lowerCaseLetter = oneOf $ String.toCharArray "_abcdefghijklmnopqrstuvwxyz"

-- | Parser for characters at the start of constructors and types
upperCaseLetter :: Parser String Char
upperCaseLetter = upper

-- | Parser for all characters after the first in names
anyLetter :: Parser String Char
anyLetter = lowerCaseLetter <|> upperCaseLetter <|> char '\'' <|> anyDigit

-- | List of reserved key words
reservedWords :: List String
reservedWords = toList $ (unGenLanguageDef haskellDef).reservedNames

character' :: Parser String Char
character' =
      (char '\\' *>
        (    (char 'n' *> return '\n')
         <|> (char 'r' *> return '\r')
         <|> char '\\'
         <|> char '"'
         <|> char '\''))
  <|> (noneOf ['\\', '\'', '"'])

character :: Parser String Atom
character = liftM1 (Char <<< String.fromChar) tokenParser.charLiteral

-- | Parser for variables names
name :: Parser String String
name = do
  c <- lowerCaseLetter
  cs <- many anyLetter
  let nm = String.fromCharArray $ fromList $ Cons c cs
  case elemIndex nm reservedWords of
    Nothing -> return nm
    Just _  -> fail $ nm ++ " is a reserved word!"

-- | Parser for variable atoms
variable :: Parser String Atom
variable = Name <$> name

-- | Parser for atoms
atom :: Parser String Atom
atom = int <|> variable <|> bool <|> character

---------------------------------------------------------
-- Parsers for Expressions
---------------------------------------------------------

-- | Fail if the specified parser matches.
notFollowedBy :: forall a. Parser String a -> Parser String Unit
notFollowedBy p = PC.try $ (PC.try p *> fail "Negated parser succeeded") <|> return unit

-- | Table for operator parsers and their AST representation. Sorted by precedence.
infixOperators :: Array (Array (Tuple3 (Parser String String) Op Assoc))
infixOperators =
  [ [ (tuple3 (string ".") Composition AssocRight) ]
  , [ (tuple3 (string "^") Power AssocRight) ]
  , [ (tuple3 (string "*") Mul AssocLeft)
    , (tuple3 (string "`div`") Div AssocLeft)
    , (tuple3 (string "`mod`") Mod AssocLeft)
    ]
  , [ (tuple3 (PC.try $ string "+" <* notFollowedBy (char '+')) Add AssocLeft)
    , (tuple3 (string "-") Sub AssocLeft)
    ]
  , [ (tuple3 (string ":") Colon AssocRight)
    , (tuple3 (string "++") Append AssocRight)
    ]
  , [ (tuple3 (string "==") Equ AssocNone)
    , (tuple3 (string "/=") Neq AssocNone)
    , (tuple3 (PC.try $ string "<" <* notFollowedBy (char '=')) Lt AssocNone)
    , (tuple3 (PC.try $ string ">" <* notFollowedBy (char '=')) Gt AssocNone)
    , (tuple3 (string "<=") Leq AssocNone)
    , (tuple3 (string ">=") Geq AssocNone)
    ]
  , [ (tuple3 (string "&&") And AssocRight) ]
  , [ (tuple3 (string "||") Or AssocRight) ]
  , [ (tuple3 (string "$") Dollar AssocRight) ]
  ]

-- | Table of operators (math, boolean, ...)
operatorTable :: OperatorTable Identity String Expr
operatorTable = maybe infixTable id (modifyAt 3 (flip snoc unaryMinus) infixTable)
  where
    infixTable :: OperatorTable Identity String Expr
    infixTable = ((uncurry3 (\p op assoc -> Infix (spaced p *> return (Binary op)) assoc)) <$>) <$> infixOperators
    unaryMinus :: Operator Identity String Expr
    unaryMinus = Prefix (spaced (string "-") *> return  (\e -> case e of
                                                          (Atom (AInt ai)) -> (Atom (AInt (-ai)))
                                                          _                -> Unary Sub e
                                                        ))

-- | Parser for operators
opParser :: Parser String Op
opParser = PC.choice $ ((uncurry3 (\p op _ -> p *> return op)) <$>) $ concat $ (toList <$>) $ toList infixOperators

-- | Parse an expression between brackets
brackets :: forall a. Parser String a -> Parser String a
brackets = tokenParser.parens

-- | Parse an expression between spaces (backtracks)
spaced :: forall a. Parser String a -> Parser String a
spaced p = PC.try $ PC.between eatSpaces eatSpaces p

-- | Parse a base expression (atoms) or an arbitrary expression inside brackets
base :: Parser String Expr -> Parser String Expr
base expr =
      PC.try (tuplesOrBrackets expr)
  <|> PC.try (lambda expr)
  <|> section expr
  <|> list expr
  <|> charList
  <|> (Atom <$> atom)

-- | Parse syntax constructs like if_then_else, lambdas or function application
syntax :: Parser String Expr -> Parser String Expr
syntax expr =
      PC.try (ifThenElse expr)
  <|> PC.try (letExpr expr)
  <|> PC.try (infixExpr expr)
  <|> applicationOrSingleExpression expr

infixExpr :: Parser String Expr -> Parser String Expr
infixExpr expr = do
  e1 <- base expr
  eatSpaces
  char '`'
  s  <- name
  char '`'
  eatSpaces
  e2 <- base expr
  case s of
    "div" -> return $ Binary Div e1 e2
    "mod" -> return $ Binary Mod e1 e2
    _     -> return $ App (Atom (Name s)) $ toList [e1, e2]

-- | Parser for function application or single expressions
applicationOrSingleExpression :: Parser String Expr -> Parser String Expr
applicationOrSingleExpression expr = do
  e <- (base expr)
  mArgs <- PC.optionMaybe (PC.try $ eatSpaces *> ((PC.try (base expr)) `PC.sepEndBy1` eatSpaces))
  case mArgs of
    Nothing   -> return e
    Just args -> return $ App e args

-- | Parse an if_then_else construct
ifThenElse :: Parser String Expr -> Parser String Expr
ifThenElse expr = do
  string "if" *> PC.lookAhead (oneOf [' ', '\t', '\n', '('])
  testExpr <- spaced expr
  string "then"
  thenExpr <- spaced expr
  string "else"
  elseExpr <- spaced expr
  return $ IfExpr testExpr thenExpr elseExpr

-- | Parser for tuples or bracketed expressions.
tuplesOrBrackets :: Parser String Expr -> Parser String Expr
tuplesOrBrackets expr = do
  char '(' *> eatSpaces
  e <- expr
  eatSpaces
  mes <- PC.optionMaybe $ PC.try $ do
    char ',' *> eatSpaces
    expr `PC.sepBy1` (PC.try $ eatSpaces *> char ',' *> eatSpaces)
  eatSpaces
  char ')'
  case mes of
    Nothing -> return e
    Just es -> return $ NTuple (Cons e es)

-- | Parser for operator sections
section :: Parser String Expr -> Parser String Expr
section expr = do
  char '('
  eatSpaces
  me1 <- PC.optionMaybe (syntax expr)
  eatSpaces
  op <- opParser
  eatSpaces
  me2 <- PC.optionMaybe (syntax expr)
  eatSpaces
  char ')'
  case me1 of
    Nothing ->
      case me2 of
        Nothing -> return $ PrefixOp op
        Just e2 -> return $ SectR op e2
    Just e1 ->
      case me2 of
        Nothing -> return $ SectL e1 op
        Just _ -> fail "Cannot have a section with two expressions!"

-- | Parser for lists
list :: Parser String Expr -> Parser String Expr
list expr = do
  char '['
  eatSpaces
  exprs <- expr `PC.sepBy` (PC.try $ eatSpaces *> char ',' *> eatSpaces)
  eatSpaces
  char ']'
  return $ List exprs

-- | Parser for strings ("example")
charList :: Parser String Expr
charList = do
  char '"'
  strs <- many character'
  char '"'
  return (List ((Atom <<< Char <<< String.fromChar) <$> strs))

-- | Parse a lambda expression
lambda :: Parser String Expr -> Parser String Expr
lambda expr = do
  char '\\' *> eatSpaces
  binds <- (binding `PC.sepEndBy1` eatSpaces)
  string "->" *> eatSpaces
  body <- expr
  return $ Lambda binds body

-- | Parser for let expression
letExpr :: Parser String Expr -> Parser String Expr
letExpr expr = do
  string "let" *> eatSpaces
  bnd <- binding
  eatSpaces *> char '=' *> eatSpaces
  lexp <- expr
  eatSpaces *> string "in" *> eatSpaces
  body <- expr
  return $ LetExpr bnd lexp body

-- | Parse an arbitrary expression
expression :: Parser String Expr
expression = do
  whiteSpace
  fix $ \expr -> buildExprParser operatorTable (syntax expr)

parseExpr :: String -> Either ParseError Expr
parseExpr input = runParser input expression

---------------------------------------------------------
-- Parsers for Bindings
---------------------------------------------------------

lit :: Parser String Binding
lit = Lit <$> atom

consLit :: Parser String Binding -> Parser String Binding
consLit bnd = do
  char '(' *> eatSpaces
  b <- consLit'
  eatSpaces *> char ')'
  return b
  where
    consLit' :: Parser String Binding
    consLit' = do
      b <- bnd
      eatSpaces *> char ':' *> eatSpaces
      bs <- PC.try consLit' <|> bnd
      return $ ConsLit b bs

listLit :: Parser String Binding -> Parser String Binding
listLit bnd = do
  char '[' *> eatSpaces
  bs <- bnd `PC.sepBy` (PC.try $ eatSpaces *> char ',' *> eatSpaces)
  eatSpaces *> char ']'
  return $ ListLit bs

tupleLit :: Parser String Binding -> Parser String Binding
tupleLit bnd = do
  char '(' *> eatSpaces
  b <- bnd
  eatSpaces *> char ',' *> eatSpaces
  bs <- bnd `PC.sepBy1` (PC.try $ eatSpaces *> char ',' *> eatSpaces)
  eatSpaces *> char ')'
  return $ NTupleLit (Cons b bs)

binding :: Parser String Binding
binding = fix $ \bnd ->
      (PC.try $ consLit bnd)
  <|> (tupleLit bnd)
  <|> (listLit bnd)
  <|> lit

---------------------------------------------------------
-- Parsers for Definitions
---------------------------------------------------------

definition :: Parser String Definition
definition = do
  defName <- name
  eatSpaces
  binds <- binding `PC.sepEndBy` eatSpaces
  char '='
  eatSpaces
  body <- expression
  return $ Def defName binds body

definitions :: Parser String (List Definition)
definitions = do
  whiteSpace
  definition `PC.sepEndBy` whiteSpace

parseDefs :: String -> Either ParseError (List Definition)
parseDefs input = runParser input definitions

module Parser where

import Prelude (Unit, bind, return, ($), (<$>), (<<<), unit, (++), void, id, flip, negate)
import Global (readInt)
import Data.String as String
import Data.Int (floor)
import Data.List (List(Cons), many, toList, concat, elemIndex, fromList)
import Data.Maybe (Maybe(..), maybe)
import Data.Tuple.Nested (Tuple3, uncurry3, tuple3)
import Data.Array (modifyAt, snoc)

import Control.Alt ((<|>))
import Control.Apply ((<*), (*>))
import Control.Lazy (fix)
import Data.Identity (Identity)
import Data.Either (Either)

import Text.Parsing.Parser (ParseError, Parser, runParser, fail)
import Text.Parsing.Parser.Combinators as PC
import Text.Parsing.Parser.Expr (OperatorTable, Assoc(AssocRight, AssocNone, AssocLeft), Operator(Infix, Prefix), buildExprParser)
import Text.Parsing.Parser.String (whiteSpace, char, string, oneOf, noneOf)

import AST (Atom(..), Binding(..), Definition(Def), Expr(..), Op(..))

---------------------------------------------------------
-- Parsers for Atoms
---------------------------------------------------------

-- | Skip spaces and tabs
eatSpaces :: Parser String Unit
eatSpaces = void $ many $ oneOf [' ','\t']

anyDigit :: Parser String Char
anyDigit = oneOf $ String.toCharArray "0123456789"

-- | Parser for Int. (0 to 2^31-1)
int :: Parser String Atom
int = do
  d <- anyDigit
  ds <- many anyDigit
  let value = floor $ readInt 10 $ String.fromCharArray $ fromList (Cons d ds)
  return $ AInt value

-- | Parser for Boolean
bool :: Parser String Atom
bool = do
  PC.choice $ toList [string "True" *> return (Bool true), string "False" *> return (Bool false)]

-- | Parser for characters at the start of variables
lowerCaseLetter :: Parser String Char
lowerCaseLetter = oneOf $ String.toCharArray "_abcdefghijklmnopqrstuvwxyz"

-- | Parser for characters at the start of constructors and types
upperCaseLetter :: Parser String Char
upperCaseLetter = oneOf $ String.toCharArray "ABCDEFGHIJKLMNOPQRSTUVWXYZ"

-- | Parser for all characters after the first in names
anyLetter :: Parser String Char
anyLetter = lowerCaseLetter <|> upperCaseLetter <|> char '\'' <|> anyDigit

-- | List of reserved key words
reservedWords :: List String
reservedWords = toList ["if", "then", "else", "let", "in"]

character' :: Parser String Char
character' =
      (char '\\' *>
        (    (char 'n' *> return '\n')
         <|> (char 'r' *> return '\r')
         <|> char '\\'
         <|> char '"'
         <|> char '\''))
  <|> (noneOf ['\\', '\'', '"'])

character :: Parser String Atom
character = do
  char '\''
  c <- character'
  char '\''
  return (Char $ String.fromChar c)

-- | Parser for variables names
name :: Parser String String
name = do
  c <- lowerCaseLetter
  cs <- many anyLetter
  let nm = String.fromCharArray $ fromList $ Cons c cs
  case elemIndex nm reservedWords of
    Nothing -> return nm
    Just _  -> fail $ nm ++ " is a reserved word!"

-- | Parser for variable atoms
variable :: Parser String Atom
variable = Name <$> name

-- | Parser for atoms
atom :: Parser String Atom
atom = int <|> variable <|> bool <|> character

---------------------------------------------------------
-- Parsers for Expressions
---------------------------------------------------------

-- | Fail if the specified parser matches.
notFollowedBy :: forall a. Parser String a -> Parser String Unit
notFollowedBy p = PC.try $ (PC.try p *> fail "Negated parser succeeded") <|> return unit

-- | Table for operator parsers and their AST representation. Sorted by precedence.
infixOperators :: Array (Array (Tuple3 (Parser String String) Op Assoc))
infixOperators =
  [ [ (tuple3 (string ".") Composition AssocRight) ]
  , [ (tuple3 (string "^") Power AssocRight) ]
  , [ (tuple3 (string "*") Mul AssocLeft)
    , (tuple3 (string "`div`") Div AssocLeft)
    , (tuple3 (string "`mod`") Mod AssocLeft)
    ]
  , [ (tuple3 (PC.try $ string "+" <* notFollowedBy (char '+')) Add AssocLeft)
    , (tuple3 (string "-") Sub AssocLeft)
    ]
  , [ (tuple3 (string ":") Colon AssocRight)
    , (tuple3 (string "++") Append AssocRight)
    ]
  , [ (tuple3 (string "==") Equ AssocNone)
    , (tuple3 (string "/=") Neq AssocNone)
    , (tuple3 (PC.try $ string "<" <* notFollowedBy (char '=')) Lt AssocNone)
    , (tuple3 (PC.try $ string ">" <* notFollowedBy (char '=')) Gt AssocNone)
    , (tuple3 (string "<=") Leq AssocNone)
    , (tuple3 (string ">=") Geq AssocNone)
    ]
  , [ (tuple3 (string "&&") And AssocRight) ]
  , [ (tuple3 (string "||") Or AssocRight) ]
  , [ (tuple3 (string "$") Dollar AssocRight) ]
  ]

-- | Table of operators (math, boolean, ...)
operatorTable :: OperatorTable Identity String Expr
operatorTable = maybe infixTable id (modifyAt 3 (flip snoc unaryMinus) infixTable)
  where
    infixTable :: OperatorTable Identity String Expr
    infixTable = ((uncurry3 (\p op assoc -> Infix (spaced p *> return (Binary op)) assoc)) <$>) <$> infixOperators
    unaryMinus :: Operator Identity String Expr
    unaryMinus = Prefix (spaced (string "-") *> return  (\e -> case e of
                                                          (Atom (AInt ai)) -> (Atom (AInt (-ai)))
                                                          _                -> Unary Sub e
                                                        ))

-- | Parser for operators
opParser :: Parser String Op
opParser = PC.choice $ ((uncurry3 (\p op _ -> p *> return op)) <$>) $ concat $ (toList <$>) $ toList infixOperators

-- | Parse an expression between brackets
brackets :: forall a. Parser String a -> Parser String a
brackets p = PC.between (char '(' *> eatSpaces) (eatSpaces *> char ')') p

-- | Parse an expression between spaces (backtracks)
spaced :: forall a. Parser String a -> Parser String a
spaced p = PC.try $ PC.between eatSpaces eatSpaces p

-- | Parse a base expression (atoms) or an arbitrary expression inside brackets
base :: Parser String Expr -> Parser String Expr
base expr =
      PC.try (tuplesOrBrackets expr)
  <|> PC.try (lambda expr)
  <|> section expr
  <|> list expr
  <|> charList
  <|> (Atom <$> atom)

-- | Parse syntax constructs like if_then_else, lambdas or function application
syntax :: Parser String Expr -> Parser String Expr
syntax expr =
      PC.try (ifThenElse expr)
  <|> PC.try (letExpr expr)
  <|> applicationOrSingleExpression expr

-- | Parser for function application or single expressions
applicationOrSingleExpression :: Parser String Expr -> Parser String Expr
applicationOrSingleExpression expr = do
  e <- (base expr)
  mArgs <- PC.optionMaybe (PC.try $ eatSpaces *> ((PC.try (base expr)) `PC.sepEndBy1` eatSpaces))
  case mArgs of
    Nothing   -> return e
    Just args -> return $ App e args

-- | Parse an if_then_else construct
ifThenElse :: Parser String Expr -> Parser String Expr
ifThenElse expr = do
  string "if" *> PC.lookAhead (oneOf [' ', '\t', '\n', '('])
  testExpr <- spaced expr
  string "then"
  thenExpr <- spaced expr
  string "else"
  elseExpr <- spaced expr
  return $ IfExpr testExpr thenExpr elseExpr

-- | Parser for tuples or bracketed expressions.
tuplesOrBrackets :: Parser String Expr -> Parser String Expr
tuplesOrBrackets expr = do
  char '(' *> eatSpaces
  e <- expr
  eatSpaces
  mes <- PC.optionMaybe $ PC.try $ do
    char ',' *> eatSpaces
    expr `PC.sepBy1` (PC.try $ eatSpaces *> char ',' *> eatSpaces)
  eatSpaces
  char ')'
  case mes of
    Nothing -> return e
    Just es -> return $ NTuple (Cons e es)

-- | Parser for operator sections
section :: Parser String Expr -> Parser String Expr
section expr = do
  char '('
  eatSpaces
  me1 <- PC.optionMaybe (syntax expr)
  eatSpaces
  op <- opParser
  eatSpaces
  me2 <- PC.optionMaybe (syntax expr)
  eatSpaces
  char ')'
  case me1 of
    Nothing ->
      case me2 of
        Nothing -> return $ PrefixOp op
        Just e2 -> return $ SectR op e2
    Just e1 ->
      case me2 of
        Nothing -> return $ SectL e1 op
        Just _ -> fail "Cannot have a section with two expressions!"

-- | Parser for lists
list :: Parser String Expr -> Parser String Expr
list expr = do
  char '['
  eatSpaces
  exprs <- expr `PC.sepBy` (PC.try $ eatSpaces *> char ',' *> eatSpaces)
  eatSpaces
  char ']'
  return $ List exprs

-- | Parser for strings ("example")
charList :: Parser String Expr
charList = do
  char '"'
  strs <- many character'
  char '"'
  return (List ((Atom <<< Char <<< String.fromChar) <$> strs))

-- | Parse a lambda expression
lambda :: Parser String Expr -> Parser String Expr
lambda expr = do
  char '(' *> eatSpaces
  char '\\' *> eatSpaces
  binds <- (binding `PC.sepEndBy1` eatSpaces)
  string "->" *> eatSpaces
  body <- expr
  eatSpaces
  char ')'
  return $ Lambda binds body

-- | Parser for let expression
letExpr :: Parser String Expr -> Parser String Expr
letExpr expr = do
  string "let" *> eatSpaces
  bnd <- binding
  eatSpaces *> char '=' *> eatSpaces
  lexp <- expr
  eatSpaces *> string "in" *> eatSpaces
  body <- expr
  return $ LetExpr bnd lexp body

-- | Parse an arbitrary expression
expression :: Parser String Expr
expression = fix $ \expr -> buildExprParser operatorTable (syntax expr)

parseExpr :: String -> Either ParseError Expr
parseExpr input = runParser input expression

---------------------------------------------------------
-- Parsers for Bindings
---------------------------------------------------------

lit :: Parser String Binding
lit = Lit <$> atom

consLit :: Parser String Binding -> Parser String Binding
consLit bnd = do
  char '(' *> eatSpaces
  b <- consLit'
  eatSpaces *> char ')'
  return b
  where
    consLit' :: Parser String Binding
    consLit' = do
      b <- bnd
      eatSpaces *> char ':' *> eatSpaces
      bs <- PC.try consLit' <|> bnd
      return $ ConsLit b bs

listLit :: Parser String Binding -> Parser String Binding
listLit bnd = do
  char '[' *> eatSpaces
  bs <- bnd `PC.sepBy` (PC.try $ eatSpaces *> char ',' *> eatSpaces)
  eatSpaces *> char ']'
  return $ ListLit bs

tupleLit :: Parser String Binding -> Parser String Binding
tupleLit bnd = do
  char '(' *> eatSpaces
  b <- bnd
  eatSpaces *> char ',' *> eatSpaces
  bs <- bnd `PC.sepBy1` (PC.try $ eatSpaces *> char ',' *> eatSpaces)
  eatSpaces *> char ')'
  return $ NTupleLit (Cons b bs)

binding :: Parser String Binding
binding = fix $ \bnd ->
      (PC.try $ consLit bnd)
  <|> (tupleLit bnd)
  <|> (listLit bnd)
  <|> lit

---------------------------------------------------------
-- Parsers for Definitions
---------------------------------------------------------

definition :: Parser String Definition
definition = do
  defName <- name
  eatSpaces
  binds <- binding `PC.sepEndBy` eatSpaces
  char '='
  eatSpaces
  body <- expression
  return $ Def defName binds body

definitions :: Parser String (List Definition)
definitions = do
  whiteSpace
  definition `PC.sepEndBy` whiteSpace

parseDefs :: String -> Either ParseError (List Definition)
parseDefs input = runParser input definitions


refactor

refactor

module Server where

import Debug.Trace
import Data.Tuple
import Data.JSON
import Data.Function
import Data.Maybe
import Data.Array
import qualified Data.Either as E
import qualified Data.Map as M
import Data.Foldable (for_)
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Control.Reactive.Timer

import qualified NodeWebSocket as WS
import qualified NodeHttp as Http
import Types
import Game
import Utils

initialState :: ServerState
initialState =
  { game: initialGame
  , input: M.empty
  , connections: []
  }

stepsPerSecond = 30

main = do
  refState <- newRef initialState

  chdir "static"
  port <- portOrDefault 8080

  httpServer <- createHttpServer
  wsServer <- createWebSocketServer refState

  WS.mount wsServer httpServer
  Http.listen httpServer port
  trace $ "listening on " <> show port <> "..."

  startMainLoop refState

createHttpServer =
  Http.createServer $ \req res -> do
    let path = (Http.getUrl req).pathname
    let reply =
      case path of
          "/"           -> Http.sendFile "index.html"
          "/js/game.js" -> Http.sendFile "js/game.js"
          _             -> Http.send404
    reply res

createWebSocketServer refState = do
  server <- WS.mkServer
  WS.onRequest server $ \req -> do
    trace "got a request"
    conn <- WS.accept req

    maybePId <- addPlayer conn refState

    case maybePId of
      Just pId -> do
        trace $ "opened connection for player " <> show pId
        WS.onMessage conn (handleMessage refState pId)
        WS.onClose   conn (handleClose refState pId)
      Nothing -> do
        trace "rejecting connection, no player ids available"
        WS.close conn

  return server

startMainLoop refState =
  void $ interval (1000 / stepsPerSecond) $ do
    s <- readRef refState

    let result = stepGame s.input s.game
    let game' = fst result
    let updates = snd result

    let s' = s { game = game', input = M.empty }
    writeRef refState s'

    sendUpdates refState updates

addPlayer conn refState = do
  state <- readRef refState
  case getNextPlayerId state of
    Just pId -> do
      let state' = state
                    { connections = state.connections <> [Tuple conn pId] }
      writeRef refState state'
      return (Just pId)
    Nothing ->
      return Nothing

getNextPlayerId :: ServerState -> Maybe PlayerId
getNextPlayerId state =
  let playerIdsInUse = map snd state.connections
  in  head $ allPlayerIds \\ playerIdsInUse

handleMessage :: forall e.
  RefVal ServerState
  -> PlayerId
  -> WS.Message
  -> Eff (trace :: Trace, ws :: WS.WebSocket, ref :: Ref | e) Unit
handleMessage refState pId msg = do
  case eitherDecode msg of
    E.Right newDir ->
      modifyRef refState $ \s ->
        let newInput = M.insert pId (Just newDir) s.input
        in  s { input = newInput }
    E.Left err ->
      trace err

handleClose :: forall e.
  RefVal ServerState
  -> PlayerId
  -> WS.Close
  -> Eff (ws :: WS.WebSocket, trace :: Trace, ref :: Ref | e) Unit
handleClose refState pId _ = do
  state <- readRef refState
  let conns = filter (\(Tuple _ pId') -> pId /= pId') state.connections
  let state' = state { connections = conns }
  writeRef refState state'
  trace $ "closed connection for player " <> show pId

sendUpdates :: forall e.
  RefVal ServerState
  -> [GameUpdate]
  -> Eff (ref :: Ref, ws :: WS.WebSocket | e) Unit
sendUpdates refState updates = do
  state <- readRef refState
  for_ updates $ \update ->
    for_ state.connections $ \(Tuple conn _) ->
      sendUpdate conn update

sendUpdate :: forall e.
  WS.Connection -> GameUpdate -> Eff (ws :: WS.WebSocket | e) Unit
sendUpdate conn update =
  when (shouldBroadcast update) $
    WS.send conn $ encode update

shouldBroadcast :: GameUpdate -> Boolean
shouldBroadcast (GUPU _ (ChangedPosition _)) = true
shouldBroadcast _ = false

foreign import data Process :: !

foreign import chdir
  """
  function chdir(path) {
    return function() {
      process.chdir(path)
    }
  }
  """ :: forall e. String -> Eff (process :: Process | e) Unit

foreign import getEnvImpl
  """
  function getEnvImpl(just, nothing, key) {
    return function() {
      var v = process.env[key]
      return v ? just(v) : nothing
    }
  }
  """ :: forall e a.
  Fn3
    (a -> Maybe a)
    (Maybe a)
    String
    (Eff (process :: Process | e) (Maybe String))

getEnv :: forall e.
  String -> Eff (process :: Process | e) (Maybe String)
getEnv key =
  runFn3 getEnvImpl Just Nothing key

parseNumber :: String -> Maybe Number
parseNumber = decode

portOrDefault :: forall e.
  Number -> Eff (process :: Process | e) Number
portOrDefault default = do
  port <- getEnv "PORT"
  return $ fromMaybe default (port >>= parseNumber)

module Server where

import Debug.Trace
import Data.Tuple
import Data.JSON
import Data.Function
import Data.Maybe
import Data.Array
import qualified Data.Either as E
import qualified Data.Map as M
import Data.Foldable (for_)
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Control.Reactive.Timer

import qualified NodeWebSocket as WS
import qualified NodeHttp as Http
import Types
import Game
import Utils

initialState :: ServerState
initialState =
  { game: initialGame
  , input: M.empty
  , connections: []
  }

main = do
  refState <- newRef initialState

  chdir "static"
  port <- portOrDefault 8080

  httpServer <- createHttpServer
  wsServer <- createWebSocketServer refState

  WS.mount wsServer httpServer
  Http.listen httpServer port
  trace $ "listening on " <> show port <> "..."

  startMainLoop refState

createHttpServer =
  Http.createServer $ \req res -> do
    let path = (Http.getUrl req).pathname
    let reply =
      case path of
          "/"           -> Http.sendFile "index.html"
          "/js/game.js" -> Http.sendFile "js/game.js"
          _             -> Http.send404
    reply res

createWebSocketServer refState = do
  server <- WS.mkServer
  WS.onRequest server $ \req -> do
    trace "got a request"
    conn <- WS.accept req

    maybePId <- addPlayer conn refState

    case maybePId of
      Just pId -> do
        trace $ "opened connection for player " <> show pId
        WS.onMessage conn (handleMessage refState pId)
        WS.onClose   conn (handleClose refState pId)
      Nothing -> do
        trace "rejecting connection, no player ids available"
        WS.close conn

  return server

startMainLoop refState =
  void $ interval 33 $ do
    s <- readRef refState

    let result = stepGame s.input s.game
    let game' = fst result
    let updates = snd result

    let s' = s { game = game', input = M.empty }
    writeRef refState s'

    sendUpdates refState updates

addPlayer conn refState = do
  state <- readRef refState
  case getNextPlayerId state of
    Just pId -> do
      let state' = state
                    { connections = state.connections <> [Tuple conn pId] }
      writeRef refState state'
      return (Just pId)
    Nothing ->
      return Nothing

getNextPlayerId :: ServerState -> Maybe PlayerId
getNextPlayerId state =
  let playerIdsInUse = map snd state.connections
  in  head $ allPlayerIds \\ playerIdsInUse

handleMessage :: forall e.
  RefVal ServerState
  -> PlayerId
  -> WS.Message
  -> Eff (trace :: Trace, ws :: WS.WebSocket, ref :: Ref | e) Unit
handleMessage refState pId msg = do
  case eitherDecode msg of
    E.Right newDir ->
      modifyRef refState $ \s ->
        let newInput = M.insert pId (Just newDir) s.input
        in  s { input = newInput }
    E.Left err ->
      trace err

handleClose :: forall e.
  RefVal ServerState
  -> PlayerId
  -> WS.Close
  -> Eff (ws :: WS.WebSocket, trace :: Trace, ref :: Ref | e) Unit
handleClose refState pId _ = do
  state <- readRef refState
  let conns = filter (\(Tuple _ pId') -> pId /= pId') state.connections
  let state' = state { connections = conns }
  writeRef refState state'
  trace $ "closed connection for player " <> show pId

sendUpdates :: forall e.
  RefVal ServerState
  -> [GameUpdate]
  -> Eff (ref :: Ref, ws :: WS.WebSocket | e) Unit
sendUpdates refState updates = do
  state <- readRef refState
  for_ updates $ \update ->
    for_ state.connections $ \(Tuple conn _) ->
      sendUpdate conn update

sendUpdate :: forall e.
  WS.Connection -> GameUpdate -> Eff (ws :: WS.WebSocket | e) Unit
sendUpdate conn update =
  when (shouldBroadcast update) $
    WS.send conn $ encode update

shouldBroadcast :: GameUpdate -> Boolean
shouldBroadcast (GUPU _ (ChangedPosition _)) = true
shouldBroadcast _ = false

foreign import data Process :: !

foreign import chdir
  """
  function chdir(path) {
    return function() {
      process.chdir(path)
    }
  }
  """ :: forall e. String -> Eff (process :: Process | e) Unit

foreign import getEnvImpl
  """
  function getEnvImpl(just, nothing, key) {
    return function() {
      var v = process.env[key]
      return v ? just(v) : nothing
    }
  }
  """ :: forall e a.
  Fn3
    (a -> Maybe a)
    (Maybe a)
    String
    (Eff (process :: Process | e) (Maybe String))

getEnv :: forall e.
  String -> Eff (process :: Process | e) (Maybe String)
getEnv key =
  runFn3 getEnvImpl Just Nothing key

parseNumber :: String -> Maybe Number
parseNumber = decode

portOrDefault :: forall e.
  Number -> Eff (process :: Process | e) Number
portOrDefault default = do
  port <- getEnv "PORT"
  return $ fromMaybe default (port >>= parseNumber)