Tidy

Tidy

Original commit 95d618e1b05af4b8b8feb3bb11a9f04e7dc05192

module CSharp
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Foldable (find, for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, camelCase, stringEscape)
import Data.Tuple (Tuple(..))
import Partial.Unsafe (unsafePartial)

import Utils (removeElement)

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

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , extension: "cs"
    , doc: csharpDoc
    , transforms:
        { nameForClass
        , unionName
        , unionPredicate
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        }
    }

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = csNameStyle $ combineNames names

unionName :: List String -> String
unionName s =
    L.sort s
    <#> csNameStyle
    # intercalate "Or"

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

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || (generalCategory c == Just LetterNumber)

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

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    -- FIXME: use the type to infer a name?
    Nothing -> "Empty"
    Just s ->
        if isStartCharacter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("_" <> str)

renderUnionToCSharp :: Set IRType -> Doc String
renderUnionToCSharp s =
    case nullableFromSet s of
    Just x -> do
        rendered <- renderTypeToCSharp x
        pure if isValueType x then rendered <> "?" else rendered
    Nothing -> lookupUnionName s

renderTypeToCSharp :: IRType -> Doc String
renderTypeToCSharp = case _ of
    IRNothing -> pure "object"
    IRNull -> pure "object"
    IRInteger -> pure "int"
    IRDouble -> pure "double"
    IRBool -> pure "bool"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderTypeToCSharp a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderTypeToCSharp t
        pure $ "Dictionary<string, " <> rendered <> ">"
    IRUnion types -> renderUnionToCSharp $ unionToSet types

csNameStyle :: String -> String
csNameStyle = camelCase >>> capitalize >>> legalizeIdentifier

csharpDoc :: Doc Unit
csharpDoc = do
    line """// To parse this JSON data, add NuGet 'Newtonsoft.Json' then do:
//
//    var data = QuickType.Converter.FromJson(jsonString);
//
namespace QuickType
{"""

    blank
    indent do
        line """using System;
using System.Net;
using System.Collections.Generic;

using Newtonsoft.Json;"""
        blank
        renderJsonConverter
        blank
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderCSharpClass cd className
            blank
        unions <- getUnions
        for_ unions \types -> do
            renderCSharpUnion types
            blank
    line "}"

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 Converter" <> stringIfTrue haveUnions ": JsonConverter"
    line "{"
    indent do
        toplevelType <- getTopLevel >>= renderTypeToCSharp
        line "// Loading helpers"
        let converterParam = stringIfTrue haveUnions ", new Converter()"
        line
            $ "public static "
            <> toplevelType
            <> " FromJson(string json) => JsonConvert.DeserializeObject<"
            <> toplevelType
            <> ">(json"
            <> converterParam
            <> ");"

        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 "}"
            blank
            line "public override void WriteJson(JsonWriter writer, object value, JsonSerializer serializer)"
            line "{"
            indent $ line "throw new NotImplementedException();"
            line "}"
            blank
            line "public override bool CanWrite => false;"
    line "}"

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

renderNullDeserializer :: Set IRType -> Doc Unit
renderNullDeserializer types =
    when (S.member IRNull types) 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 -> Set IRType -> Doc Unit
renderPrimitiveDeserializer tokenTypes t types =
    when (S.member t types) do
        for_ tokenTypes \tokenType -> do
            tokenCase tokenType
        indent do
            deserializeType t

renderDoubleDeserializer :: Set IRType -> Doc Unit
renderDoubleDeserializer types =
    when (S.member IRDouble types) do
        unless (S.member IRInteger types) do
            tokenCase "Integer"
        tokenCase "Float"
        indent do
            deserializeType IRDouble

renderGenericDeserializer :: (IRType -> Boolean) -> String -> Set IRType -> Doc Unit
renderGenericDeserializer predicate tokenType types = unsafePartial $
    case find predicate types of
    Nothing -> pure unit
    Just t -> do
        tokenCase tokenType
        indent do
            deserializeType t

renderCSharpUnion :: Set IRType -> Doc Unit
renderCSharpUnion allTypes = do
    name <- lookupUnionName allTypes
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) allTypes
    line $ "public struct " <> name
    line "{"
    indent do
        for_ nonNullTypes \t -> do
            typeString <- renderUnionToCSharp $ S.union (S.singleton t) (S.singleton IRNull)
            field <- unionFieldName t
            line $ "public " <> typeString <> " " <> field <> ";"
        blank
        line $ "public " <> name <> "(JsonReader reader, JsonSerializer serializer)"
        line "{"
        indent do
            for_ (L.fromFoldable nonNullTypes) \field -> do
                fieldName <- unionFieldName field
                line $ fieldName <> " = null;"
            blank
            line "switch (reader.TokenType)"
            line "{"
            indent do
                renderNullDeserializer allTypes
                renderPrimitiveDeserializer (L.singleton "Integer") IRInteger allTypes
                renderDoubleDeserializer allTypes
                renderPrimitiveDeserializer (L.singleton "Boolean") IRBool allTypes
                renderPrimitiveDeserializer ("String" : "Date" : L.Nil) IRString allTypes
                renderGenericDeserializer isArray "StartArray" allTypes
                renderGenericDeserializer isClass "StartObject" allTypes
                renderGenericDeserializer isMap "StartObject" allTypes
                line $ "default: throw new Exception(\"Cannot convert " <> name <> "\");"
            line "}"
        line "}"
    line "}"

renderCSharpClass :: IRClassData -> String -> Doc Unit
renderCSharpClass (IRClassData { names, properties }) className = do
    let propertyNames = transformNames csNameStyle ("Other" <> _) (S.singleton className) $ map (\n -> Tuple n n) $ M.keys properties
    line $ "public class " <> className
    line "{"
    indent do
        for_ (M.toUnfoldable properties :: Array _) \(Tuple pname ptype) -> do
            line $ "[JsonProperty(\"" <> stringEscape pname <> "\")]"
            rendered <- renderTypeToCSharp ptype
            let csPropName = lookupName pname propertyNames
            line $ "public " <> rendered <> " " <> csPropName <> " { get; set; }"
            blank
    line "}"

module CSharp
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Foldable (find, for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), isNothing)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, camelCase, stringEscape)
import Data.Tuple (Tuple(..))
import Partial.Unsafe (unsafePartial)

import Utils (removeElement)

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

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , extension: "cs"
    , doc: csharpDoc
    , transforms:
        { nameForClass
        , unionName
        , unionPredicate
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        }
    }

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = csNameStyle $ combineNames names

unionName :: List String -> String
unionName s =
    L.sort s
    <#> csNameStyle
    # intercalate "Or"

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

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || (generalCategory c == Just LetterNumber)

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

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    -- FIXME: use the type to infer a name?
    Nothing -> "Empty"
    Just s ->
        if isStartCharacter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("_" <> str)

renderUnionToCSharp :: Set IRType -> Doc String
renderUnionToCSharp s =
    case nullableFromSet s of
    Just x -> do
        rendered <- renderTypeToCSharp x
        pure if isValueType x then rendered <> "?" else rendered
    Nothing -> lookupUnionName s

renderTypeToCSharp :: IRType -> Doc String
renderTypeToCSharp = case _ of
    IRNothing -> pure "object"
    IRNull -> pure "object"
    IRInteger -> pure "int"
    IRDouble -> pure "double"
    IRBool -> pure "bool"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderTypeToCSharp a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderTypeToCSharp t
        pure $ "Dictionary<string, " <> rendered <> ">"
    IRUnion types -> renderUnionToCSharp $ unionToSet types

csNameStyle :: String -> String
csNameStyle = camelCase >>> capitalize >>> legalizeIdentifier

csharpDoc :: Doc Unit
csharpDoc = do
    line """// To parse this JSON data, add NuGet 'Newtonsoft.Json' then do:
//
//    var data = QuickType.Converter.FromJson(jsonString);
//
namespace QuickType
{"""

    blank
    indent do
        line """using System;
using System.Net;
using System.Collections.Generic;

using Newtonsoft.Json;"""
        blank
        renderJsonConverter
        blank
        classes <- getClasses
        for_ classes \(Tuple i cd) -> do
            className <- lookupClassName i
            renderCSharpClass cd className
            blank
        unions <- getUnions
        for_ unions \types -> do
            renderCSharpUnion types
            blank
    line "}"

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 Converter" <> stringIfTrue haveUnions ": JsonConverter"
    line "{"
    indent do
        toplevelType <- getTopLevel >>= renderTypeToCSharp
        line "// Loading helpers"
        let converterParam = stringIfTrue haveUnions ", new Converter()"
        line
            $ "public static "
            <> toplevelType
            <> " FromJson(string json) => JsonConvert.DeserializeObject<"
            <> toplevelType
            <> ">(json"
            <> converterParam
            <> ");"

        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 "}"
            blank
            line "public override void WriteJson(JsonWriter writer, object value, JsonSerializer serializer)"
            line "{"
            indent $ line "throw new NotImplementedException();"
            line "}"
            blank
            line "public override bool CanWrite => false;"
    line "}"

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

renderNullDeserializer :: Set IRType -> Doc Unit
renderNullDeserializer types =
    when (S.member IRNull types) 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 -> Set IRType -> Doc Unit
renderPrimitiveDeserializer tokenTypes t types =
    when (S.member t types) do
        for_ tokenTypes \tokenType -> do
            tokenCase tokenType
        indent do
            deserializeType t

renderDoubleDeserializer :: Set IRType -> Doc Unit
renderDoubleDeserializer types =
    when (S.member IRDouble types) do
        unless (S.member IRInteger types) do
            tokenCase "Integer"
        tokenCase "Float"
        indent do
            deserializeType IRDouble

renderGenericDeserializer :: (IRType -> Boolean) -> String -> Set IRType -> Doc Unit
renderGenericDeserializer predicate tokenType types = unsafePartial $
    case find predicate types of
    Nothing -> pure unit
    Just t -> do
        tokenCase tokenType
        indent do
            deserializeType t

renderCSharpUnion :: Set IRType -> Doc Unit
renderCSharpUnion allTypes = do
    name <- lookupUnionName allTypes
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) allTypes
    line $ "public struct " <> name
    line "{"
    indent do
        for_ nonNullTypes \t -> do
            typeString <- renderUnionToCSharp $ S.union (S.singleton t) (S.singleton IRNull)
            field <- unionFieldName t
            line $ "public " <> typeString <> " " <> field <> ";"
        blank
        line $ "public " <> name <> "(JsonReader reader, JsonSerializer serializer)"
        line "{"
        indent do
            for_ (L.fromFoldable nonNullTypes) \field -> do
                fieldName <- unionFieldName field
                line $ fieldName <> " = null;"
            blank
            line "switch (reader.TokenType)"
            line "{"
            indent do
                renderNullDeserializer allTypes
                renderPrimitiveDeserializer (L.singleton "Integer") IRInteger allTypes
                renderDoubleDeserializer allTypes
                renderPrimitiveDeserializer (L.singleton "Boolean") IRBool allTypes
                renderPrimitiveDeserializer ("String" : "Date" : L.Nil) IRString allTypes
                renderGenericDeserializer isArray "StartArray" allTypes
                renderGenericDeserializer isClass "StartObject" allTypes
                renderGenericDeserializer isMap "StartObject" allTypes
                line $ "default: throw new Exception(\"Cannot convert " <> name <> "\");"
            line "}"
        line "}"
    line "}"

renderCSharpClass :: IRClassData -> String -> Doc Unit
renderCSharpClass (IRClassData { names, properties }) className = do
    let propertyNames = transformNames csNameStyle ("Other" <> _) (S.singleton className) $ map (\n -> Tuple n n) $ M.keys properties
    line $ "public class " <> className
    line "{"
    indent do
        for_ (M.toUnfoldable properties :: Array _) \(Tuple pname ptype) -> do
            line $ "[JsonProperty(\"" <> stringEscape pname <> "\")]"
            rendered <- renderTypeToCSharp ptype
            let csPropName = lookupName pname propertyNames
            line $ "public " <> rendered <> " " <> csPropName <> " { get; set; }"
            blank
    line "}"


Remove fixed FIXME

Remove fixed FIXME

Original commit 6609940fe1cf927cde5cbefe2e83447986d04d59

module Golang
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isDigit, isLetter)
import Data.Foldable (for_, intercalate, foldl)
import Data.List (List, (:))
import Data.List as L
import Data.Map as Map
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, camelCase, stringEscape)
import Data.Tuple (Tuple(..), fst)
import Utils (mapM, removeElement, sortByKeyM, sortByKey)

renderer :: Renderer
renderer =
    { name: "Go"
    , aceMode: "golang"
    , extension: "go"
    , doc: golangDoc
    , transforms:
        { nameForClass
        , unionName: Just unionName
        , unionPredicate: Just unionPredicate
        , nextName: \s -> "Other" <> s
        , forbiddenNames: []
        }
    }

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = goNameStyle $ combineNames names

unionName :: L.List String -> String
unionName s =
    L.sort s
    <#> goNameStyle
    # intercalate "Or"

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType IRString = true
isValueType (IRClass _) = true
isValueType _ = false

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || c == '_'

isStartCharacter :: Char -> Boolean
isStartCharacter = isLetterCharacter

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    isLetterCharacter c || isDigit c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isLetter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("F_" <> str)

noComment :: String -> Doc { rendered :: String, comment :: Maybe String }
noComment rendered =
    pure { rendered, comment: Nothing }

renderUnionToGolang :: Set IRType -> Doc { rendered :: String, comment :: Maybe String }
renderUnionToGolang s =
    case nullableFromSet s of
    Just x -> do
        { rendered, comment } <- renderTypeToGolang x
        pure
            if isValueType x then
                { rendered: "*" <> rendered, comment: Just $ maybe "optional" ("optional "<> _) comment }
            else
                { rendered, comment: Nothing }
    Nothing -> do
        noComment =<< lookupUnionName s

renderTypeToGolang :: IRType -> Doc { rendered :: String, comment :: Maybe String }
renderTypeToGolang = case _ of
    IRNothing -> noComment "interface{}"
    IRNull -> noComment "interface{}"
    IRInteger -> noComment "int64"
    IRDouble -> noComment "float64"
    IRBool -> noComment "bool"
    IRString -> noComment "string"
    IRArray a -> do
        { rendered, comment } <- renderTypeToGolang a
        pure { rendered: "[]" <> rendered, comment: map ("array of " <> _) comment }
    IRClass i -> noComment =<< lookupClassName i
    IRMap t -> do
        { rendered, comment } <- renderTypeToGolang t
        pure { rendered: "map[string]" <> rendered, comment: map ("map to " <> _) comment }
    IRUnion types -> renderUnionToGolang $ unionToSet types

renderComment :: Maybe String -> String
renderComment (Just s) = " /* " <> s <> " */"
renderComment Nothing = ""

goNameStyle :: String -> String
goNameStyle = camelCase >>> capitalize >>> legalizeIdentifier

golangDoc :: Doc Unit
golangDoc = do
    line """// To parse and unparse this JSON data, add this code to your project and do:
//
//    r, err := UnmarshalRoot(bytes)
//    bytes, err = r.Marshal()

package main
"""
    unions <- getUnions
    unless (unions == L.Nil) do
        line "import \"bytes\""
        line "import \"errors\""
    line "import \"encoding/json\""
    blank
    { rendered: renderedToplevel, comment: toplevelComment } <- getTopLevel >>= renderTypeToGolang
    line $ "type Root " <> renderedToplevel <> (renderComment toplevelComment)
    blank
    line """func UnmarshalRoot(data []byte) (Root, error) {
	var r Root
	err := json.Unmarshal(data, &r)
	return r, err
}

func (r *Root) Marshal() ([]byte, error) {
	return json.Marshal(r)
}
"""
    classes <- getClasses
    for_ classes \(Tuple i cls) -> do
        renderGolangType i cls
        blank
    unless (unions == L.Nil) do
        line """func unmarshalUnion(data []byte, pi **int64, pf **float64, pb **bool, ps **string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) (bool, error) {
	if pi != nil {
		*pi = nil
	}
	if pf != nil {
		*pf = nil
	}
	if pb != nil {
		*pb = nil
	}
	if ps != nil {
		*ps = nil
	}

	dec := json.NewDecoder(bytes.NewReader(data))
	dec.UseNumber()
	tok, err := dec.Token()
	if err != nil {
		return false, err
	}

	switch v := tok.(type) {
	case json.Number:
		if pi != nil {
			i, err := v.Int64()
			if err == nil {
				*pi = &i
				return false, nil
			}
		}
		if pf != nil {
			f, err := v.Float64()
			if err == nil {
				*pf = &f
				return false, nil
			}
			return false, errors.New("Unparsable number")
		}
		return false, errors.New("Union does not contain number")
	case float64:
		return false, errors.New("Decoder should not return float64")
	case bool:
		if pb != nil {
			*pb = &v
			return false, nil
		}
		return false, errors.New("Union does not contain bool")
	case string:
		if ps != nil {
			*ps = &v
			return false, nil
		}
		return false, errors.New("Union does not contain string")
	case nil:
		if nullable {
			return false, nil
		}
		return false, errors.New("Union does not contain null")
	case json.Delim:
		if v == '{' {
			if haveObject {
				return true, json.Unmarshal(data, pc)
			}
			if haveMap {
				return false, json.Unmarshal(data, pm)
			}
			return false, errors.New("Union does not contain object")
		}
		if v == '[' {
			if haveArray {
				return false, json.Unmarshal(data, pa)
			}
			return false, errors.New("Union does not contain array")
		}
		return false, errors.New("Cannot handle delimiter")
	}
	return false, errors.New("Cannot unmarshal union")

}

func marshalUnion(pi *int64, pf *float64, pb *bool, ps *string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) ([]byte, error) {
	if pi != nil {
		return json.Marshal(*pi)
	}
	if pf != nil {
		return json.Marshal(*pf)
	}
	if pb != nil {
		return json.Marshal(*pb)
	}
	if ps != nil {
		return json.Marshal(*ps)
	}
	if haveArray {
		return json.Marshal(pa)
	}
	if haveObject {
		return json.Marshal(pc)
	}
	if haveMap {
		return json.Marshal(pm)
	}
	if nullable {
		return json.Marshal(nil)
	}
	return nil, errors.New("Union must not be null")
}"""
    for_ unions \types -> do
        blank
        renderGolangUnion types

pad :: Int -> String -> String
pad n s = s <> Str.fromCharArray (A.replicate (n - (Str.length s)) ' ')

columnize :: List (List String) -> Doc Unit
columnize L.Nil = pure unit
columnize rows@(firstRow : otherRows) =
    let columnWidths = foldl (\m l -> L.zipWith max m $ map Str.length l) (map Str.length firstRow) otherRows
        paddedRows = map (L.zipWith pad columnWidths) rows
    in
        for_ paddedRows \row -> do
            line $ Str.trim $ intercalate " " row

renderStruct :: String -> List (List String) -> Doc Unit
renderStruct name columns = do
    line $ "type " <> name <> " struct {"
    indent do
        columnize columns
    line "}"

renderGolangType :: Int -> IRClassData -> Doc Unit
renderGolangType classIndex (IRClassData { names, properties }) = do
    className <- lookupClassName classIndex
    let propertyNames = transformNames goNameStyle ("Other" <> _) S.empty $ map (\n -> Tuple n n) $ Map.keys properties
    let propsList = Map.toUnfoldable properties # sortByKey (\t -> lookupName (fst t) propertyNames)
    columns <- propsList # mapM \(Tuple pname ptype) -> do
        let csPropName = lookupName pname propertyNames
        { rendered, comment } <- renderTypeToGolang ptype
        pure $ (csPropName : rendered : ("`json:\"" <> (stringEscape pname) <> "\"`" <> renderComment comment) : L.Nil)
    renderStruct className columns

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

compoundPredicates :: Array (IRType -> Boolean)
compoundPredicates = [isArray, isClass, isMap]

renderGolangUnion :: Set IRType -> Doc Unit
renderGolangUnion allTypes = do
    name <- lookupUnionName allTypes
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) allTypes
    let isNullableString = if isJust emptyOrNull then "true" else "false"
    fields <- L.fromFoldable nonNullTypes # sortByKeyM unionFieldName
    columns <- fields # mapM \t -> do
        { rendered, comment } <- renderUnionToGolang $ S.union (S.singleton t) (S.singleton IRNull)
        field <- unionFieldName t
        pure $ (field : (rendered <> renderComment comment) : L.Nil)
    renderStruct name columns
    blank
    line $ "func (x *" <> name <> ") UnmarshalJSON(data []byte) error {"
    indent do
        for_ compoundPredicates \p -> maybeAssignNil p
        ifClass \_ typeString -> do
            line $ "var c " <> typeString
        args <- makeArgs primitiveUnmarshalArg compoundUnmarshalArg
        line $ "object, err := unmarshalUnion(data, " <> args <> ", " <> isNullableString <> ")"
        line "if err != nil {"
        indent do
    		line "return err"
        line "}"
        line "if object {"
        ifClass \name _ -> do
            indent do
                line $ "x." <> name <> " = &c"
        line "}"
        line "return nil"
    line "}"
    blank
    line $ "func (x *" <> name <> ") MarshalJSON() ([]byte, error) {"
    indent do
        args <- makeArgs primitiveMarshalArg compoundMarshalArg
        line $ "return marshalUnion(" <> args <> ", " <> isNullableString <> ")"
    line "}"
    where
        ifClass :: (String -> String -> Doc Unit) -> Doc Unit
        ifClass f =
            let { element } = removeElement isClass allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    { rendered } <- renderTypeToGolang t
                    f name rendered
                Nothing -> pure unit
        maybeAssignNil p =
            let { element } = removeElement p allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    line $ "x." <> name <> " = nil"
                Nothing -> pure unit
        makeArgs :: (IRType -> Doc String) -> ((IRType -> Boolean) -> Doc String) -> Doc String
        makeArgs primitive compound = do
            primitiveArgs <- mapM primitive $ L.fromFoldable [IRInteger, IRDouble, IRBool, IRString]
            compoundArgs <- mapM compound $ L.fromFoldable compoundPredicates
            pure $ intercalate ", " $ A.concat [A.fromFoldable primitiveArgs, A.fromFoldable compoundArgs]
        memberArg :: String -> (IRType -> String -> String) -> (IRType -> Boolean) -> Doc String
        memberArg notPresentValue renderPresent p =
            let { element } = removeElement p allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    pure $ renderPresent t name
                Nothing -> pure notPresentValue
        primitiveUnmarshalArg t =
            memberArg "nil" (\_ n -> "&x." <> n) (eq t)
        compoundUnmarshalArg p =
            memberArg "false, nil" (\t n -> if isClass t then "true, &c" else "true, &x." <> n) p
        primitiveMarshalArg :: IRType -> Doc String
        primitiveMarshalArg t =
            memberArg "nil" (\_ n -> "x." <> n) (eq t)
        compoundMarshalArg :: (IRType -> Boolean) -> Doc String
        compoundMarshalArg p =
            memberArg "false, nil" (\t n -> "x." <> n <> " != nil, x." <> n) p

module Golang
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isDigit, isLetter)
import Data.Foldable (for_, intercalate, foldl)
import Data.List (List, (:))
import Data.List as L
import Data.Map as Map
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, camelCase, stringEscape)
import Data.Tuple (Tuple(..), fst)
import Utils (mapM, removeElement, sortByKeyM, sortByKey)

renderer :: Renderer
renderer =
    { name: "Go"
    , aceMode: "golang"
    , extension: "go"
    , doc: golangDoc
    , transforms:
        { nameForClass
        , unionName: Just unionName
        , unionPredicate: Just unionPredicate
        , nextName: \s -> "Other" <> s
        , forbiddenNames: []
        }
    }

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = goNameStyle $ combineNames names

unionName :: L.List String -> String
unionName s =
    L.sort s
    <#> goNameStyle
    # intercalate "Or"

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType IRString = true
isValueType (IRClass _) = true
isValueType _ = false

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || c == '_'

isStartCharacter :: Char -> Boolean
isStartCharacter = isLetterCharacter

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    isLetterCharacter c || isDigit c

legalizeIdentifier :: String -> String
legalizeIdentifier str =
    case Str.charAt 0 str of
    -- FIXME: use the type to infer a name?
    Nothing -> "Empty"
    Just s ->
        if isLetter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier ("F_" <> str)

noComment :: String -> Doc { rendered :: String, comment :: Maybe String }
noComment rendered =
    pure { rendered, comment: Nothing }

renderUnionToGolang :: Set IRType -> Doc { rendered :: String, comment :: Maybe String }
renderUnionToGolang s =
    case nullableFromSet s of
    Just x -> do
        { rendered, comment } <- renderTypeToGolang x
        pure
            if isValueType x then
                { rendered: "*" <> rendered, comment: Just $ maybe "optional" ("optional "<> _) comment }
            else
                { rendered, comment: Nothing }
    Nothing -> do
        noComment =<< lookupUnionName s

renderTypeToGolang :: IRType -> Doc { rendered :: String, comment :: Maybe String }
renderTypeToGolang = case _ of
    IRNothing -> noComment "interface{}"
    IRNull -> noComment "interface{}"
    IRInteger -> noComment "int64"
    IRDouble -> noComment "float64"
    IRBool -> noComment "bool"
    IRString -> noComment "string"
    IRArray a -> do
        { rendered, comment } <- renderTypeToGolang a
        pure { rendered: "[]" <> rendered, comment: map ("array of " <> _) comment }
    IRClass i -> noComment =<< lookupClassName i
    IRMap t -> do
        { rendered, comment } <- renderTypeToGolang t
        pure { rendered: "map[string]" <> rendered, comment: map ("map to " <> _) comment }
    IRUnion types -> renderUnionToGolang $ unionToSet types

renderComment :: Maybe String -> String
renderComment (Just s) = " /* " <> s <> " */"
renderComment Nothing = ""

goNameStyle :: String -> String
goNameStyle = camelCase >>> capitalize >>> legalizeIdentifier

golangDoc :: Doc Unit
golangDoc = do
    line """// To parse and unparse this JSON data, add this code to your project and do:
//
//    r, err := UnmarshalRoot(bytes)
//    bytes, err = r.Marshal()

package main
"""
    unions <- getUnions
    unless (unions == L.Nil) do
        line "import \"bytes\""
        line "import \"errors\""
    line "import \"encoding/json\""
    blank
    { rendered: renderedToplevel, comment: toplevelComment } <- getTopLevel >>= renderTypeToGolang
    line $ "type Root " <> renderedToplevel <> (renderComment toplevelComment)
    blank
    line """func UnmarshalRoot(data []byte) (Root, error) {
	var r Root
	err := json.Unmarshal(data, &r)
	return r, err
}

func (r *Root) Marshal() ([]byte, error) {
	return json.Marshal(r)
}
"""
    classes <- getClasses
    for_ classes \(Tuple i cls) -> do
        renderGolangType i cls
        blank
    unless (unions == L.Nil) do
        line """func unmarshalUnion(data []byte, pi **int64, pf **float64, pb **bool, ps **string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) (bool, error) {
	if pi != nil {
		*pi = nil
	}
	if pf != nil {
		*pf = nil
	}
	if pb != nil {
		*pb = nil
	}
	if ps != nil {
		*ps = nil
	}

	dec := json.NewDecoder(bytes.NewReader(data))
	dec.UseNumber()
	tok, err := dec.Token()
	if err != nil {
		return false, err
	}

	switch v := tok.(type) {
	case json.Number:
		if pi != nil {
			i, err := v.Int64()
			if err == nil {
				*pi = &i
				return false, nil
			}
		}
		if pf != nil {
			f, err := v.Float64()
			if err == nil {
				*pf = &f
				return false, nil
			}
			return false, errors.New("Unparsable number")
		}
		return false, errors.New("Union does not contain number")
	case float64:
		return false, errors.New("Decoder should not return float64")
	case bool:
		if pb != nil {
			*pb = &v
			return false, nil
		}
		return false, errors.New("Union does not contain bool")
	case string:
		if ps != nil {
			*ps = &v
			return false, nil
		}
		return false, errors.New("Union does not contain string")
	case nil:
		if nullable {
			return false, nil
		}
		return false, errors.New("Union does not contain null")
	case json.Delim:
		if v == '{' {
			if haveObject {
				return true, json.Unmarshal(data, pc)
			}
			if haveMap {
				return false, json.Unmarshal(data, pm)
			}
			return false, errors.New("Union does not contain object")
		}
		if v == '[' {
			if haveArray {
				return false, json.Unmarshal(data, pa)
			}
			return false, errors.New("Union does not contain array")
		}
		return false, errors.New("Cannot handle delimiter")
	}
	return false, errors.New("Cannot unmarshal union")

}

func marshalUnion(pi *int64, pf *float64, pb *bool, ps *string, haveArray bool, pa interface{}, haveObject bool, pc interface{}, haveMap bool, pm interface{}, nullable bool) ([]byte, error) {
	if pi != nil {
		return json.Marshal(*pi)
	}
	if pf != nil {
		return json.Marshal(*pf)
	}
	if pb != nil {
		return json.Marshal(*pb)
	}
	if ps != nil {
		return json.Marshal(*ps)
	}
	if haveArray {
		return json.Marshal(pa)
	}
	if haveObject {
		return json.Marshal(pc)
	}
	if haveMap {
		return json.Marshal(pm)
	}
	if nullable {
		return json.Marshal(nil)
	}
	return nil, errors.New("Union must not be null")
}"""
    for_ unions \types -> do
        blank
        renderGolangUnion types

pad :: Int -> String -> String
pad n s = s <> Str.fromCharArray (A.replicate (n - (Str.length s)) ' ')

columnize :: List (List String) -> Doc Unit
columnize L.Nil = pure unit
columnize rows@(firstRow : otherRows) =
    let columnWidths = foldl (\m l -> L.zipWith max m $ map Str.length l) (map Str.length firstRow) otherRows
        paddedRows = map (L.zipWith pad columnWidths) rows
    in
        for_ paddedRows \row -> do
            line $ Str.trim $ intercalate " " row

renderStruct :: String -> List (List String) -> Doc Unit
renderStruct name columns = do
    line $ "type " <> name <> " struct {"
    indent do
        columnize columns
    line "}"

renderGolangType :: Int -> IRClassData -> Doc Unit
renderGolangType classIndex (IRClassData { names, properties }) = do
    className <- lookupClassName classIndex
    let propertyNames = transformNames goNameStyle ("Other" <> _) S.empty $ map (\n -> Tuple n n) $ Map.keys properties
    let propsList = Map.toUnfoldable properties # sortByKey (\t -> lookupName (fst t) propertyNames)
    columns <- propsList # mapM \(Tuple pname ptype) -> do
        let csPropName = lookupName pname propertyNames
        { rendered, comment } <- renderTypeToGolang ptype
        pure $ (csPropName : rendered : ("`json:\"" <> (stringEscape pname) <> "\"`" <> renderComment comment) : L.Nil)
    renderStruct className columns

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

compoundPredicates :: Array (IRType -> Boolean)
compoundPredicates = [isArray, isClass, isMap]

renderGolangUnion :: Set IRType -> Doc Unit
renderGolangUnion allTypes = do
    name <- lookupUnionName allTypes
    let { element: emptyOrNull, rest: nonNullTypes } = removeElement (_ == IRNull) allTypes
    let isNullableString = if isJust emptyOrNull then "true" else "false"
    fields <- L.fromFoldable nonNullTypes # sortByKeyM unionFieldName
    columns <- fields # mapM \t -> do
        { rendered, comment } <- renderUnionToGolang $ S.union (S.singleton t) (S.singleton IRNull)
        field <- unionFieldName t
        pure $ (field : (rendered <> renderComment comment) : L.Nil)
    renderStruct name columns
    blank
    line $ "func (x *" <> name <> ") UnmarshalJSON(data []byte) error {"
    indent do
        for_ compoundPredicates \p -> maybeAssignNil p
        ifClass \_ typeString -> do
            line $ "var c " <> typeString
        args <- makeArgs primitiveUnmarshalArg compoundUnmarshalArg
        line $ "object, err := unmarshalUnion(data, " <> args <> ", " <> isNullableString <> ")"
        line "if err != nil {"
        indent do
    		line "return err"
        line "}"
        line "if object {"
        ifClass \name _ -> do
            indent do
                line $ "x." <> name <> " = &c"
        line "}"
        line "return nil"
    line "}"
    blank
    line $ "func (x *" <> name <> ") MarshalJSON() ([]byte, error) {"
    indent do
        args <- makeArgs primitiveMarshalArg compoundMarshalArg
        line $ "return marshalUnion(" <> args <> ", " <> isNullableString <> ")"
    line "}"
    where
        ifClass :: (String -> String -> Doc Unit) -> Doc Unit
        ifClass f =
            let { element } = removeElement isClass allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    { rendered } <- renderTypeToGolang t
                    f name rendered
                Nothing -> pure unit
        maybeAssignNil p =
            let { element } = removeElement p allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    line $ "x." <> name <> " = nil"
                Nothing -> pure unit
        makeArgs :: (IRType -> Doc String) -> ((IRType -> Boolean) -> Doc String) -> Doc String
        makeArgs primitive compound = do
            primitiveArgs <- mapM primitive $ L.fromFoldable [IRInteger, IRDouble, IRBool, IRString]
            compoundArgs <- mapM compound $ L.fromFoldable compoundPredicates
            pure $ intercalate ", " $ A.concat [A.fromFoldable primitiveArgs, A.fromFoldable compoundArgs]
        memberArg :: String -> (IRType -> String -> String) -> (IRType -> Boolean) -> Doc String
        memberArg notPresentValue renderPresent p =
            let { element } = removeElement p allTypes
            in
                case element of
                Just t -> do
                    name <- unionFieldName t
                    pure $ renderPresent t name
                Nothing -> pure notPresentValue
        primitiveUnmarshalArg t =
            memberArg "nil" (\_ n -> "&x." <> n) (eq t)
        compoundUnmarshalArg p =
            memberArg "false, nil" (\t n -> if isClass t then "true, &c" else "true, &x." <> n) p
        primitiveMarshalArg :: IRType -> Doc String
        primitiveMarshalArg t =
            memberArg "nil" (\_ n -> "x." <> n) (eq t)
        compoundMarshalArg :: (IRType -> Boolean) -> Doc String
        compoundMarshalArg p =
            memberArg "false, nil" (\t n -> "x." <> n <> " != nil, x." <> n) p


Support all SI prefixes

Support all SI prefixes

module Insect (
  repl
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.Apply (lift2)

import Data.Quantity
import Data.Quantity.Math

import Data.Units
import Data.Units.SI
import Data.Units.SI.Derived
import Data.Units.SI.Accepted
import Data.Units.Imperial
import Data.Units.Time
import Data.Units.Bit

import Data.Array (fromFoldable)
import Data.Either (Either(..))
import Data.Maybe
import Data.String

import Global (readFloat, isFinite)

import Partial.Unsafe

import Text.Parsing.StringParser
import Text.Parsing.StringParser.Combinators
import Text.Parsing.StringParser.Expr
import Text.Parsing.StringParser.String

pNumber :: Parser Number
pNumber = do
  intPart <- signAndDigits

  mFracPart <- optionMaybe (append <$> string "." <*> digits)
  let fracPart = fromMaybe "" mFracPart

  mExpPart <- optionMaybe (append <$> string "e" <*> signAndDigits)
  let expPart = fromMaybe "" mExpPart

  let num = readFloat (intPart <> fracPart <> expPart)

  if isFinite num
    then pure num
    else fail "Could not parse Number"

  where
    digits :: Parser String
    digits = do
      ds <- many1 anyDigit
      pure $ fromCharArray (fromFoldable ds)

    signAndDigits :: Parser String
    signAndDigits = do
      sign <- singleton <$> option '+' (oneOf ['+', '-'])
      intPart <- digits
      pure $ sign <> intPart

pSIPrefix :: Parser (DerivedUnit → DerivedUnit)
pSIPrefix =
      (string "a" *> pure atto)
  <|> (string "f" *> pure femto)
  <|> (string "p" *> pure pico)
  <|> (string "n" *> pure nano)
  <|> (string "µ" *> pure micro)
  <|> (string "m" *> pure milli)
  <|> (string "c" *> pure centi)
  <|> (string "d" *> pure deci)
  <|> (string "h" *> pure hecto)
  <|> (string "k" *> pure kilo)
  <|> (string "M" *> pure mega)
  <|> (string "G" *> pure giga)
  <|> (string "T" *> pure tera)
  <|> (string "P" *> pure peta)
  <|> (string "E" *> pure exa)
  <|> pure id

pImperialUnit :: Parser DerivedUnit
pImperialUnit =
      (string "miles" *> pure mile)
  <|> (string "mile"  *> pure mile)
  <|> (string "mph"   *> pure (mile ./ hour))
  <|> (string "in"    *> pure inch)
  <|> (string "ft"    *> pure foot)

pUnit :: Parser DerivedUnit
pUnit =
      (string "sec"   *> pure second)
  <|> (string "min"   *> pure minute)
  <|> (string "hours" *> pure hour)
  <|> (string "hour"  *> pure hour)
  <|> (string "h"     *> pure hour)
  <|> (string "days"  *> pure day)
  <|> (string "day"   *> pure day)
  <|> (string "d"     *> pure day)
  <|> (string "weeks" *> pure week)
  <|> (string "week"  *> pure week)
  <|> (string "m/h"   *> pure (meter ./ hour)) -- TODO
  <|> (string "m/s"   *> pure (meter ./ second)) -- TODO
  <|> (string "g"     *> pure gram)
  <|> (string "m"     *> pure meter)
  <|> (string "s"     *> pure second)
  <?> "Expected unit"

pUnitWithSIPrefix :: Parser DerivedUnit
pUnitWithSIPrefix = try withPrefix <|> try pUnit <|> pure unity
  where
    withPrefix = do
      p <- pSIPrefix
      u <- pUnit
      pure $ p u

pQuantity :: Parser Quantity
pQuantity = quantity <$> pNumber <*> pUnitWithSIPrefix

qS ea eb = do
  a <- ea
  b <- eb
  a ⊖ b

qA ea eb = do
  a <- ea
  b <- eb
  a ⊕ b

pExpr :: Parser (Either UnificationError Quantity)
pExpr = buildExprParser [ [ Infix (string "/" $> lift2 (⊘)) AssocRight ]
                        , [ Infix (string "*" $> lift2 (⊗)) AssocRight ]
                        , [ Infix (string "-" $> qS) AssocRight ]
                        , [ Infix (string "+" $> qA) AssocRight ]
                        ] (pure <$> pQuantity)

pInput :: Parser (Either UnificationError Quantity)
pInput = try (map toStandard <$> (pExpr <* eof))
  <|> conversion
  where
    conversion = do
      expr <- pExpr
      string " to "
      target <- pUnitWithSIPrefix
      eof
      pure (expr >>= (flip convertTo) target)

repl :: String -> { out :: String, divClass :: String }
repl inp =
  case runParser pInput inp of
    Left parseErr -> { out: show parseErr, divClass: "error" }
    Right res ->
      case res of
        Left unificationError -> { out: errorMessage unificationError, divClass: "error" }
        Right val -> { out: prettyPrint val, divClass: "value" }

module Insect (
  repl
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.Apply (lift2)

import Data.Quantity
import Data.Quantity.Math

import Data.Units
import Data.Units.SI
import Data.Units.SI.Derived
import Data.Units.SI.Accepted
import Data.Units.Imperial
import Data.Units.Time
import Data.Units.Bit

import Data.Array (fromFoldable)
import Data.Either (Either(..))
import Data.Maybe
import Data.String

import Global (readFloat, isFinite)

import Partial.Unsafe

import Text.Parsing.StringParser
import Text.Parsing.StringParser.Combinators
import Text.Parsing.StringParser.Expr
import Text.Parsing.StringParser.String

pNumber :: Parser Number
pNumber = do
  intPart <- signAndDigits

  mFracPart <- optionMaybe (append <$> string "." <*> digits)
  let fracPart = fromMaybe "" mFracPart

  mExpPart <- optionMaybe (append <$> string "e" <*> signAndDigits)
  let expPart = fromMaybe "" mExpPart

  let num = readFloat (intPart <> fracPart <> expPart)

  if isFinite num
    then pure num
    else fail "Could not parse Number"

  where
    digits :: Parser String
    digits = do
      ds <- many1 anyDigit
      pure $ fromCharArray (fromFoldable ds)

    signAndDigits :: Parser String
    signAndDigits = do
      sign <- singleton <$> option '+' (oneOf ['+', '-'])
      intPart <- digits
      pure $ sign <> intPart

pPrefix :: Parser (DerivedUnit → DerivedUnit)
pPrefix =
      (string "µ" *> pure micro)
  <|> (string "m" *> pure milli)
  <|> (string "c" *> pure centi)
  <|> (string "h" *> pure hecto)
  <|> (string "k" *> pure kilo)
  <|> (string "M" *> pure mega)
  <|> (string "G" *> pure giga)
  <|> pure id

pImperialUnit :: Parser DerivedUnit
pImperialUnit =
      (string "miles" *> pure mile)
  <|> (string "mile"  *> pure mile)
  <|> (string "mph"   *> pure (mile ./ hour))
  <|> (string "in"    *> pure inch)
  <|> (string "ft"    *> pure foot)

pUnit :: Parser DerivedUnit
pUnit =
      (string "sec"   *> pure second)
  <|> (string "min"   *> pure minute)
  <|> (string "hours" *> pure hour)
  <|> (string "hour"  *> pure hour)
  <|> (string "h"     *> pure hour)
  <|> (string "days"  *> pure day)
  <|> (string "day"   *> pure day)
  <|> (string "d"     *> pure day)
  <|> (string "weeks" *> pure week)
  <|> (string "week"  *> pure week)
  <|> (string "m/h"   *> pure (meter ./ hour)) -- TODO
  <|> (string "m/s"   *> pure (meter ./ second)) -- TODO
  <|> (string "g"     *> pure gram)
  <|> (string "m"     *> pure meter)
  <|> (string "s"     *> pure second)
  <?> "Expected unit"

pUnitWithPrefix :: Parser DerivedUnit
pUnitWithPrefix = try withPrefix <|> try pUnit <|> pure unity
  where
    withPrefix = do
      p <- pPrefix
      u <- pUnit
      pure $ p u

pQuantity :: Parser Quantity
pQuantity = quantity <$> pNumber <*> pUnitWithPrefix

qS ea eb = do
  a <- ea
  b <- eb
  a ⊖ b

qA ea eb = do
  a <- ea
  b <- eb
  a ⊕ b

pExpr :: Parser (Either UnificationError Quantity)
pExpr = buildExprParser [ [ Infix (string "/" $> lift2 (⊘)) AssocRight ]
                        , [ Infix (string "*" $> lift2 (⊗)) AssocRight ]
                        , [ Infix (string "-" $> qS) AssocRight ]
                        , [ Infix (string "+" $> qA) AssocRight ]
                        ] (pure <$> pQuantity)

pInput :: Parser (Either UnificationError Quantity)
pInput = try (map toStandard <$> (pExpr <* eof))
  <|> conversion
  where
    conversion = do
      expr <- pExpr
      string " to "
      target <- pUnitWithPrefix
      eof
      pure (expr >>= (flip convertTo) target)

repl :: String -> { out :: String, divClass :: String }
repl inp =
  case runParser pInput inp of
    Left parseErr -> { out: show parseErr, divClass: "error" }
    Right res ->
      case res of
        Left unificationError -> { out: errorMessage unificationError, divClass: "error" }
        Right val -> { out: prettyPrint val, divClass: "value" }


tweak

tweak

module Server where

import Debug.Trace
import Data.Tuple
import Data.Function
import Data.Maybe
import Data.Foldable (for_)
import Data.Foreign.EasyFFI
import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Ref
import Control.Reactive.Timer

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

main = do
  unsafeForeignFunction [""] "process.chdir('../static')"
  port <- unsafeForeignFunction [""] "process.env.PORT || 8080"

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

  wsServer <- mkWebSocketServer
  WS.mount wsServer httpServer

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

mkWebSocketServer :: forall e.
  Eff ( ws :: WS.WebSocket
      , timer :: Timer
      , ref :: Ref
      , trace :: Trace | e
      ) WS.Server
mkWebSocketServer = do
  server <- WS.mkServer
  WS.onRequest server handleRequest
  return server

handleRequest :: forall e.
  WS.Request
  -> Eff ( ws :: WS.WebSocket
         , timer :: Timer
         , ref :: Ref
         , trace :: Trace | e
         ) Unit
handleRequest req = do
  conn <- WS.accept req
  trace "opened connection"
  gameRef <- newRef initialGame
  inputRef <- newRef $ Input Nothing

  WS.onMessage conn (handleMessage inputRef)
  WS.onClose conn handleClose

  interval 100 $ do
    input <- readRef inputRef
    game <- readRef gameRef

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

    writeRef gameRef game'
    writeRef inputRef $ Input Nothing
    sendUpdates conn updates

handleMessage :: forall e.
  RefVal Input
  -> WS.Message
  -> Eff (trace :: Trace, ref :: Ref | e) Unit
handleMessage inputRef msg = do
  trace $ "got message: " <> msg
  whenJust (parseDirection msg) $ \newDirection ->
    writeRef inputRef (Input (Just newDirection))

handleClose :: forall a e.
  a -> Eff (ws :: WS.WebSocket, trace :: Trace | e) Unit
handleClose = const (trace "closed connection")

sendUpdates :: forall e.
  WS.Connection -> [GameUpdate] -> Eff (ws :: WS.WebSocket | e) Unit
sendUpdates conn updates =
  for_ updates (sendUpdate conn)

sendUpdate :: forall e.
  WS.Connection -> GameUpdate -> Eff (ws :: WS.WebSocket | e) Unit
sendUpdate conn (ChangedPosition p) = WS.send conn $ serializeChangedPosition p
sendUpdate _ _ = return unit

serializeChangedPosition :: Position -> String
serializeChangedPosition (Position p) =
  "{\"changedPosition\":{\"x\":" <> show p.x <> ",\"y\":" <> show p.y <> "}}"

parseDirection :: String -> Maybe Direction
parseDirection d =
  case d of
    "up"    -> Just Up
    "down"  -> Just Down
    "left"  -> Just Left
    "right" -> Just Right
    _       -> Nothing

module Server where

import Debug.Trace
import Data.Tuple
import Data.Function
import Data.Maybe
import Data.Foldable (for_)
import Data.Foreign.EasyFFI
import Control.Monad.Eff
import Control.Monad.Eff.Class
import Control.Monad.Eff.Ref
import Control.Reactive.Timer

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

main = do
  unsafeForeignFunction [""] "process.chdir('../static')"
  port <- unsafeForeignFunction [""] "process.env.PORT || 8080"

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

  wsServer <- mkWebSocketServer
  WS.mount wsServer httpServer

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

mkWebSocketServer :: forall e.
  Eff ( ws :: WS.WebSocket
      , timer :: Timer
      , ref :: Ref
      , trace :: Trace | e
      ) WS.Server
mkWebSocketServer = do
  server <- WS.mkServer
  WS.onRequest server handleRequest
  return server

handleRequest :: forall e.
  WS.Request
  -> Eff ( ws :: WS.WebSocket
         , timer :: Timer
         , ref :: Ref
         , trace :: Trace | e
         ) Unit
handleRequest req = do
  conn <- WS.accept req
  trace "opened connection"
  gameRef <- newRef initialGame
  inputRef <- newRef $ Input Nothing

  WS.onMessage conn (handleMessage inputRef)

  interval 100 $ do
    input <- readRef inputRef
    game <- readRef gameRef

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

    writeRef gameRef game'
    writeRef inputRef $ Input Nothing
    sendUpdates conn updates

  return unit
  WS.onClose conn handleClose

handleMessage :: forall e.
  RefVal Input
  -> WS.Message
  -> Eff (trace :: Trace, ref :: Ref | e) Unit
handleMessage inputRef msg = do
  trace $ "got message: " <> msg
  whenJust (parseDirection msg) $ \newDirection ->
    writeRef inputRef (Input (Just newDirection))

handleClose :: forall a e.
  a -> Eff (ws :: WS.WebSocket, trace :: Trace | e) Unit
handleClose = const (trace "closed connection")

sendUpdates :: forall e.
  WS.Connection -> [GameUpdate] -> Eff (ws :: WS.WebSocket | e) Unit
sendUpdates conn updates =
  for_ updates (sendUpdate conn)

sendUpdate :: forall e.
  WS.Connection -> GameUpdate -> Eff (ws :: WS.WebSocket | e) Unit
sendUpdate conn (ChangedPosition p) = WS.send conn $ serializeChangedPosition p
sendUpdate _ _ = return unit

serializeChangedPosition :: Position -> String
serializeChangedPosition (Position p) =
  "{\"changedPosition\":{\"x\":" <> show p.x <> ",\"y\":" <> show p.y <> "}}"

parseDirection :: String -> Maybe Direction
parseDirection d =
  case d of
    "up"    -> Just Up
    "down"  -> Just Down
    "left"  -> Just Left
    "right" -> Just Right
    _       -> Nothing


Removed the FRP module note: purescript has no ecosystem

module BlueWire.FRP where

import Prelude
import Data.Maybe
import Data.Time.Duration
import BlueWire.Types
import FRP as FRP
import FRP.Event as FRP
import FRP.Behavior (Behavior)
import Data.Function
import Control.Apply
import Control.Applicative
import Control.Monad

{-
-- |
kick :: forall dur. Duration dur => dur -> Behavior (Kick dur) -> FRP.Event Unit
kick dur ki =  <$>
-}


Fn1 is just `->`

Fn1 is just `->`

module Node.FS.Sync
  ( rename
  , truncate
  , chown
  , chmod
  , stat
  , link
  , symlink
  , readlink
  , realpath
  , realpath'
  , unlink
  , rmdir
  , mkdir
  , mkdir'
  , readdir
  , utimes
  , readFile
  , readTextFile
  , writeFile
  , writeTextFile
  , appendFile
  , appendTextFile
  , exists
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Data.Date
import Data.Either
import Data.Function
import Node.Buffer (Buffer(..))
import Node.Encoding
import Node.FS
import Node.FS.Stats
import Node.Path (FilePath())

foreign import fs "var fs = require('fs');" ::
  { renameSync :: Fn2 FilePath FilePath Unit
  , truncateSync :: Fn2 FilePath Number Unit
  , chownSync :: Fn3 FilePath Number Number Unit
  , chmodSync :: Fn2 FilePath Number Unit
  , statSync :: Fn1 FilePath StatsObj
  , linkSync :: Fn2 FilePath FilePath Unit
  , symlinkSync :: Fn3 FilePath FilePath String Unit
  , readlinkSync :: Fn1 FilePath FilePath
  , realpathSync :: forall cache. Fn2 FilePath { | cache } FilePath
  , unlinkSync :: Fn1 FilePath Unit
  , rmdirSync :: Fn1 FilePath Unit
  , mkdirSync :: Fn2 FilePath Number Unit
  , readdirSync :: Fn1 FilePath [FilePath]
  , utimesSync :: Fn3 FilePath Number Number Unit
  , readFileSync :: forall a opts. Fn2 FilePath { | opts } a
  , writeFileSync :: forall a opts. Fn3 FilePath a { | opts } Unit
  , appendFileSync :: forall a opts. Fn3 FilePath a { | opts } Unit
  , existsSync :: FilePath -> Boolean
  }

foreign import mkEff
  "function mkEff(action) {\
  \  return action;\
  \}" :: forall eff a. (Unit -> a)
                    -> Eff eff a

-- |
-- Renames a file.
--
rename :: forall eff. FilePath
                   -> FilePath
                   -> Eff (fs :: FS, err :: Exception | eff) Unit

rename oldFile newFile = mkEff $ \_ -> runFn2
  fs.renameSync oldFile newFile

-- |
-- Truncates a file to the specified length.
--
truncate :: forall eff. FilePath
                     -> Number
                     -> Eff (fs :: FS, err :: Exception | eff) Unit

truncate file len = mkEff $ \_ -> runFn2
  fs.truncateSync file len

-- |
-- Changes the ownership of a file.
--
chown :: forall eff. FilePath
                  -> Number
                  -> Number
                  -> Eff (fs :: FS, err :: Exception | eff) Unit

chown file uid gid = mkEff $ \_ -> runFn3
  fs.chownSync file uid gid

-- |
-- Changes the permissions of a file.
--
chmod :: forall eff. FilePath
                  -> Number
                  -> Eff (fs :: FS, err :: Exception | eff) Unit

chmod file mode = mkEff $ \_ -> runFn2
  fs.chmodSync file mode

-- |
-- Gets file statistics.
--
stat :: forall eff. FilePath
                 -> Eff (fs :: FS, err :: Exception | eff) Stats

stat file = return $ Stats $ runFn1
  fs.statSync file

-- |
-- Creates a link to an existing file.
--
link :: forall eff. FilePath
                 -> FilePath
                 -> Eff (fs :: FS, err :: Exception | eff) Unit

link src dst = mkEff $ \_ -> runFn2
  fs.linkSync src dst

-- |
-- Creates a symlink.
--
symlink :: forall eff. FilePath
                    -> FilePath
                    -> SymlinkType
                    -> Eff (fs :: FS, err :: Exception | eff) Unit

symlink src dst ty = mkEff $ \_ -> runFn3
  fs.symlinkSync src dst (show ty)

-- |
-- Reads the value of a symlink.
--
readlink :: forall eff. FilePath
                     -> Eff (fs :: FS, err :: Exception | eff) FilePath

readlink path = mkEff $ \_ -> runFn1
  fs.readlinkSync path

-- |
-- Find the canonicalized absolute location for a path.
--
realpath :: forall eff. FilePath
                     -> Eff (fs :: FS, err :: Exception | eff) FilePath

realpath path = mkEff $ \_ -> runFn2
  fs.realpathSync path {}

-- |
-- Find the canonicalized absolute location for a path using a cache object for
-- already resolved paths.
--
realpath' :: forall eff cache. FilePath
                            -> { | cache }
                            -> Eff (fs :: FS, err :: Exception | eff) FilePath

realpath' path cache = mkEff $ \_ -> runFn2
  fs.realpathSync path cache

-- |
-- Deletes a file.
--
unlink :: forall eff. FilePath
                   -> Eff (fs :: FS, err :: Exception | eff) Unit

unlink file = mkEff $ \_ -> runFn1
  fs.unlinkSync file

-- |
-- Deletes a directory.
--
rmdir :: forall eff. FilePath
                  -> Eff (fs :: FS, err :: Exception | eff) Unit

rmdir file = mkEff $ \_ -> runFn1
  fs.rmdirSync file

-- |
-- Makes a new directory.
--
mkdir :: forall eff. FilePath
                  -> Eff (fs :: FS, err :: Exception | eff) Unit

mkdir = flip mkdir' 777

-- |
-- Makes a new directory with the specified permissions.
--
mkdir' :: forall eff. FilePath
                   -> Number
                   -> Eff (fs :: FS, err :: Exception | eff) Unit

mkdir' file mode = mkEff $ \_ -> runFn2
  fs.mkdirSync file mode

-- |
-- Reads the contents of a directory.
--
readdir :: forall eff. FilePath
                    -> Eff (fs :: FS, err :: Exception | eff) [FilePath]

readdir file = mkEff $ \_ -> runFn1
  fs.readdirSync file

-- |
-- Sets the accessed and modified times for the specified file.
--
utimes :: forall eff. FilePath
                   -> Date
                   -> Date
                   -> Eff (fs :: FS, err :: Exception | eff) Unit

utimes file atime mtime = mkEff $ \_ -> runFn3
  fs.utimesSync file
                ((toEpochMilliseconds atime) / 1000)
                ((toEpochMilliseconds mtime) / 1000)

-- |
-- Reads the entire contents of a file returning the result as a raw buffer.
--
readFile :: forall eff. FilePath
                     -> Eff (fs :: FS, err :: Exception | eff) Buffer

readFile file = mkEff $ \_ -> runFn2
  fs.readFileSync file {}

-- |
-- Reads the entire contents of a text file with the specified encoding.
--
readTextFile :: forall eff. Encoding
                         -> FilePath
                         -> Eff (fs :: FS, err :: Exception | eff) String

readTextFile encoding file = mkEff $ \_ -> runFn2
  fs.readFileSync file { encoding: show encoding }

-- |
-- Writes a buffer to a file.
--
writeFile :: forall eff. FilePath
                      -> Buffer
                      -> Eff (fs :: FS, err :: Exception | eff) Unit

writeFile file buff = mkEff $ \_ -> runFn3
  fs.writeFileSync file buff {}

-- |
-- Writes text to a file using the specified encoding.
--
writeTextFile :: forall eff. Encoding
                          -> FilePath
                          -> String
                          -> Eff (fs :: FS, err :: Exception | eff) Unit

writeTextFile encoding file text = mkEff $ \_ -> runFn3
  fs.writeFileSync file text { encoding: show encoding }

-- |
-- Appends the contents of a buffer to a file.
--
appendFile :: forall eff. FilePath
                       -> Buffer
                       -> Eff (fs :: FS, err :: Exception | eff) Unit

appendFile file buff = mkEff $ \_ -> runFn3
  fs.appendFileSync file buff {}

-- |
-- Appends text to a file using the specified encoding.
--
appendTextFile :: forall eff. Encoding
                           -> FilePath
                           -> String
                           -> Eff (fs :: FS, err :: Exception | eff) Unit

appendTextFile encoding file buff = mkEff $ \_ -> runFn3
  fs.appendFileSync file buff { encoding: show encoding }

-- |
-- Check if the path exists.
--
exists :: forall eff. FilePath
                   -> Eff (fs :: FS | eff) Boolean
exists file = mkEff $ \_ -> fs.existsSync file

module Node.FS.Sync
  ( rename
  , truncate
  , chown
  , chmod
  , stat
  , link
  , symlink
  , readlink
  , realpath
  , realpath'
  , unlink
  , rmdir
  , mkdir
  , mkdir'
  , readdir
  , utimes
  , readFile
  , readTextFile
  , writeFile
  , writeTextFile
  , appendFile
  , appendTextFile
  , exists
  ) where

import Control.Monad.Eff
import Control.Monad.Eff.Exception
import Data.Date
import Data.Either
import Data.Function
import Node.Buffer (Buffer(..))
import Node.Encoding
import Node.FS
import Node.FS.Stats
import Node.Path (FilePath())

foreign import fs "var fs = require('fs');" ::
  { renameSync :: Fn2 FilePath FilePath Unit
  , truncateSync :: Fn2 FilePath Number Unit
  , chownSync :: Fn3 FilePath Number Number Unit
  , chmodSync :: Fn2 FilePath Number Unit
  , statSync :: Fn1 FilePath StatsObj
  , linkSync :: Fn2 FilePath FilePath Unit
  , symlinkSync :: Fn3 FilePath FilePath String Unit
  , readlinkSync :: Fn1 FilePath FilePath
  , realpathSync :: forall cache. Fn2 FilePath { | cache } FilePath
  , unlinkSync :: Fn1 FilePath Unit
  , rmdirSync :: Fn1 FilePath Unit
  , mkdirSync :: Fn2 FilePath Number Unit
  , readdirSync :: Fn1 FilePath [FilePath]
  , utimesSync :: Fn3 FilePath Number Number Unit
  , readFileSync :: forall a opts. Fn2 FilePath { | opts } a
  , writeFileSync :: forall a opts. Fn3 FilePath a { | opts } Unit
  , appendFileSync :: forall a opts. Fn3 FilePath a { | opts } Unit
  , existsSync :: Fn1 FilePath Boolean
  }

foreign import mkEff
  "function mkEff(action) {\
  \  return action;\
  \}" :: forall eff a. (Unit -> a)
                    -> Eff eff a

-- |
-- Renames a file.
--
rename :: forall eff. FilePath
                   -> FilePath
                   -> Eff (fs :: FS, err :: Exception | eff) Unit

rename oldFile newFile = mkEff $ \_ -> runFn2
  fs.renameSync oldFile newFile

-- |
-- Truncates a file to the specified length.
--
truncate :: forall eff. FilePath
                     -> Number
                     -> Eff (fs :: FS, err :: Exception | eff) Unit

truncate file len = mkEff $ \_ -> runFn2
  fs.truncateSync file len

-- |
-- Changes the ownership of a file.
--
chown :: forall eff. FilePath
                  -> Number
                  -> Number
                  -> Eff (fs :: FS, err :: Exception | eff) Unit

chown file uid gid = mkEff $ \_ -> runFn3
  fs.chownSync file uid gid

-- |
-- Changes the permissions of a file.
--
chmod :: forall eff. FilePath
                  -> Number
                  -> Eff (fs :: FS, err :: Exception | eff) Unit

chmod file mode = mkEff $ \_ -> runFn2
  fs.chmodSync file mode

-- |
-- Gets file statistics.
--
stat :: forall eff. FilePath
                 -> Eff (fs :: FS, err :: Exception | eff) Stats

stat file = return $ Stats $ runFn1
  fs.statSync file

-- |
-- Creates a link to an existing file.
--
link :: forall eff. FilePath
                 -> FilePath
                 -> Eff (fs :: FS, err :: Exception | eff) Unit

link src dst = mkEff $ \_ -> runFn2
  fs.linkSync src dst

-- |
-- Creates a symlink.
--
symlink :: forall eff. FilePath
                    -> FilePath
                    -> SymlinkType
                    -> Eff (fs :: FS, err :: Exception | eff) Unit

symlink src dst ty = mkEff $ \_ -> runFn3
  fs.symlinkSync src dst (show ty)

-- |
-- Reads the value of a symlink.
--
readlink :: forall eff. FilePath
                     -> Eff (fs :: FS, err :: Exception | eff) FilePath

readlink path = mkEff $ \_ -> runFn1
  fs.readlinkSync path

-- |
-- Find the canonicalized absolute location for a path.
--
realpath :: forall eff. FilePath
                     -> Eff (fs :: FS, err :: Exception | eff) FilePath

realpath path = mkEff $ \_ -> runFn2
  fs.realpathSync path {}

-- |
-- Find the canonicalized absolute location for a path using a cache object for
-- already resolved paths.
--
realpath' :: forall eff cache. FilePath
                            -> { | cache }
                            -> Eff (fs :: FS, err :: Exception | eff) FilePath

realpath' path cache = mkEff $ \_ -> runFn2
  fs.realpathSync path cache

-- |
-- Deletes a file.
--
unlink :: forall eff. FilePath
                   -> Eff (fs :: FS, err :: Exception | eff) Unit

unlink file = mkEff $ \_ -> runFn1
  fs.unlinkSync file

-- |
-- Deletes a directory.
--
rmdir :: forall eff. FilePath
                  -> Eff (fs :: FS, err :: Exception | eff) Unit

rmdir file = mkEff $ \_ -> runFn1
  fs.rmdirSync file

-- |
-- Makes a new directory.
--
mkdir :: forall eff. FilePath
                  -> Eff (fs :: FS, err :: Exception | eff) Unit

mkdir = flip mkdir' 777

-- |
-- Makes a new directory with the specified permissions.
--
mkdir' :: forall eff. FilePath
                   -> Number
                   -> Eff (fs :: FS, err :: Exception | eff) Unit

mkdir' file mode = mkEff $ \_ -> runFn2
  fs.mkdirSync file mode

-- |
-- Reads the contents of a directory.
--
readdir :: forall eff. FilePath
                    -> Eff (fs :: FS, err :: Exception | eff) [FilePath]

readdir file = mkEff $ \_ -> runFn1
  fs.readdirSync file

-- |
-- Sets the accessed and modified times for the specified file.
--
utimes :: forall eff. FilePath
                   -> Date
                   -> Date
                   -> Eff (fs :: FS, err :: Exception | eff) Unit

utimes file atime mtime = mkEff $ \_ -> runFn3
  fs.utimesSync file
                ((toEpochMilliseconds atime) / 1000)
                ((toEpochMilliseconds mtime) / 1000)

-- |
-- Reads the entire contents of a file returning the result as a raw buffer.
--
readFile :: forall eff. FilePath
                     -> Eff (fs :: FS, err :: Exception | eff) Buffer

readFile file = mkEff $ \_ -> runFn2
  fs.readFileSync file {}

-- |
-- Reads the entire contents of a text file with the specified encoding.
--
readTextFile :: forall eff. Encoding
                         -> FilePath
                         -> Eff (fs :: FS, err :: Exception | eff) String

readTextFile encoding file = mkEff $ \_ -> runFn2
  fs.readFileSync file { encoding: show encoding }

-- |
-- Writes a buffer to a file.
--
writeFile :: forall eff. FilePath
                      -> Buffer
                      -> Eff (fs :: FS, err :: Exception | eff) Unit

writeFile file buff = mkEff $ \_ -> runFn3
  fs.writeFileSync file buff {}

-- |
-- Writes text to a file using the specified encoding.
--
writeTextFile :: forall eff. Encoding
                          -> FilePath
                          -> String
                          -> Eff (fs :: FS, err :: Exception | eff) Unit

writeTextFile encoding file text = mkEff $ \_ -> runFn3
  fs.writeFileSync file text { encoding: show encoding }

-- |
-- Appends the contents of a buffer to a file.
--
appendFile :: forall eff. FilePath
                       -> Buffer
                       -> Eff (fs :: FS, err :: Exception | eff) Unit

appendFile file buff = mkEff $ \_ -> runFn3
  fs.appendFileSync file buff {}

-- |
-- Appends text to a file using the specified encoding.
--
appendTextFile :: forall eff. Encoding
                           -> FilePath
                           -> String
                           -> Eff (fs :: FS, err :: Exception | eff) Unit

appendTextFile encoding file buff = mkEff $ \_ -> runFn3
  fs.appendFileSync file buff { encoding: show encoding }

-- |
-- Check if the path exists.
--
exists :: forall eff. FilePath
                   -> Eff (fs :: FS | eff) Boolean
exists file = mkEff $ \_ -> runFn1
  fs.existsSync file


document new StrMap test

document new StrMap test

module Test.Data.StrMap where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Random (RANDOM)

import Data.Foldable (foldl)
import Data.Function (on)
import Data.List (List(..), groupBy, sortBy, singleton, fromFoldable, zipWith)
import Data.List.NonEmpty as NEL
import Data.Maybe (Maybe(..))
import Data.StrMap as M
import Data.Tuple (Tuple(..), fst)

import Partial.Unsafe (unsafePartial)

import Test.QuickCheck ((<?>), quickCheck, quickCheck', (===))
import Test.QuickCheck.Arbitrary (class Arbitrary, arbitrary)
import Test.QuickCheck.Gen as Gen

newtype TestStrMap v = TestStrMap (M.StrMap v)

instance arbTestStrMap :: (Arbitrary v) => Arbitrary (TestStrMap v) where
  arbitrary = TestStrMap <<< (M.fromFoldable :: List (Tuple String v) -> M.StrMap v) <$> arbitrary

data Instruction k v = Insert k v | Delete k

instance showInstruction :: (Show k, Show v) => Show (Instruction k v) where
  show (Insert k v) = "Insert (" <> show k <> ") (" <> show v <> ")"
  show (Delete k) = "Delete (" <> show k <> ")"

instance arbInstruction :: (Arbitrary v) => Arbitrary (Instruction String v) where
  arbitrary = do
    b <- arbitrary
    k <- Gen.frequency (Tuple 10.0 (pure "hasOwnProperty"))
                       (Tuple 50.0 arbitrary `Cons` Nil)
    case b of
      true -> do
        v <- arbitrary
        pure (Insert k v)
      false -> do
        pure (Delete k)

runInstructions :: forall v. List (Instruction String v) -> M.StrMap v -> M.StrMap v
runInstructions instrs t0 = foldl step t0 instrs
  where
  step tree (Insert k v) = M.insert k v tree
  step tree (Delete k) = M.delete k tree

number :: Int -> Int
number n = n

strMapTests :: forall eff. Eff (console :: CONSOLE, random :: RANDOM, err :: EXCEPTION | eff) Unit
strMapTests = do
  log "Test inserting into empty tree"
  quickCheck $ \k v -> M.lookup k (M.insert k v M.empty) == Just (number v)
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Test inserting two values with same key"
  quickCheck $ \k v1 v2 ->
    M.lookup k (M.insert k v2 (M.insert k v1 M.empty)) == Just (number v2)

  log "Test delete after inserting"
  quickCheck $ \k v -> M.isEmpty (M.delete k (M.insert k (number v) M.empty))
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Test pop after inserting"
  quickCheck $ \k v -> M.pop k (M.insert k (number v) M.empty) == Just (Tuple v M.empty)
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Pop non-existent key"
  quickCheck $ \k1 k2 v -> k1 == k2 || M.pop k2 (M.insert k1 (number v) M.empty) == Nothing
    <?> ("k1: " <> show k1 <> ", k2: " <> show k2 <> ", v: " <> show v)

  log "Insert two, lookup first"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k1 (M.insert k2 (number v2) (M.insert k1 (number v1) M.empty)) == Just v1
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Insert two, lookup second"
  quickCheck $ \k1 v1 k2 v2 -> M.lookup k2 (M.insert k2 (number v2) (M.insert k1 (number v1) M.empty)) == Just v2
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Insert two, delete one"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k2 (M.delete k1 (M.insert k2 (number v2) (M.insert k1 (number v1) M.empty))) == Just v2
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Lookup from empty"
  quickCheck $ \k -> M.lookup k (M.empty :: M.StrMap Int) == Nothing

  log "Lookup from singleton"
  quickCheck $ \k v -> M.lookup k (M.singleton k (v :: Int)) == Just v

  log "Random lookup"
  quickCheck' 1000 $ \instrs k v ->
    let
      tree :: M.StrMap Int
      tree = M.insert k v (runInstructions instrs M.empty)
    in M.lookup k tree == Just v <?> ("instrs:\n  " <> show instrs <> "\nk:\n  " <> show k <> "\nv:\n  " <> show v)

  log "Singleton to list"
  quickCheck $ \k v -> M.toList (M.singleton k v :: M.StrMap Int) == singleton (Tuple k v)

  log "fromFoldable [] = empty"
  quickCheck (M.fromFoldable [] == (M.empty :: M.StrMap Unit)
    <?> "was not empty")

  log "fromFoldable & key collision"
  do
    let nums = M.fromFoldable [Tuple "0" "zero", Tuple "1" "what", Tuple "1" "one"]
    quickCheck (M.lookup "0" nums == Just "zero" <?> "invalid lookup - 0")
    quickCheck (M.lookup "1" nums == Just "one"  <?> "invalid lookup - 1")
    quickCheck (M.lookup "2" nums == Nothing     <?> "invalid lookup - 2")

  log "fromFoldableWith const [] = empty"
  quickCheck (M.fromFoldableWith const [] == (M.empty :: M.StrMap Unit)
    <?> "was not empty")

  log "fromFoldableWith (+) & key collision"
  do
    let nums = M.fromFoldableWith (+) [Tuple "0" 1, Tuple "1" 1, Tuple "1" 1]
    quickCheck (M.lookup "0" nums == Just 1  <?> "invalid lookup - 0")
    quickCheck (M.lookup "1" nums == Just 2  <?> "invalid lookup - 1")
    quickCheck (M.lookup "2" nums == Nothing <?> "invalid lookup - 2")

  log "toList . fromFoldable = id"
  quickCheck $ \arr -> let f x = M.toList (M.fromFoldable x)
                       in f (f arr) == f (arr :: List (Tuple String Int)) <?> show arr

  log "fromFoldable . toList = id"
  quickCheck $ \(TestStrMap m) ->
    let f m1 = M.fromFoldable (M.toList m1) in
    M.toList (f m) == M.toList (m :: M.StrMap Int) <?> show m

  log "fromFoldableWith const = fromFoldable"
  quickCheck $ \arr -> M.fromFoldableWith const arr ==
                       M.fromFoldable (arr :: List (Tuple String Int)) <?> show arr

  log "fromFoldableWith (<>) = fromFoldable . collapse with (<>) . group on fst"
  quickCheck $ \arr ->
    let combine (Tuple s a) (Tuple t b) = (Tuple s $ b <> a)
        foldl1 g = unsafePartial \(Cons x xs) -> foldl g x xs
        f = M.fromFoldable <<< map (foldl1 combine <<< NEL.toList) <<<
            groupBy ((==) `on` fst) <<< sortBy (compare `on` fst) in
    M.fromFoldableWith (<>) arr == f (arr :: List (Tuple String String)) <?> show arr

  log "Lookup from union"
  quickCheck $ \(TestStrMap m1) (TestStrMap m2) k ->
    M.lookup k (M.union m1 m2) == (case M.lookup k m1 of
      Nothing -> M.lookup k m2
      Just v -> Just (number v)) <?> ("m1: " <> show m1 <> ", m2: " <> show m2 <> ", k: " <> show k <> ", v1: " <> show (M.lookup k m1) <> ", v2: " <> show (M.lookup k m2) <> ", union: " <> show (M.union m1 m2))

  log "Union is idempotent"
  quickCheck $ \(TestStrMap m1) (TestStrMap m2) ->
    (m1 `M.union` m2) == ((m1 `M.union` m2) `M.union` (m2 :: M.StrMap Int)) <?> (show (M.size (m1 `M.union` m2)) <> " != " <> show (M.size ((m1 `M.union` m2) `M.union` m2)))

  log "fromFoldable = zip keys values"
  quickCheck $ \(TestStrMap m) -> M.toList m == zipWith Tuple (fromFoldable $ M.keys m) (M.values m :: List Int)

  log "mapWithKey is correct"
  quickCheck $ \(TestStrMap m :: TestStrMap Int) -> let
    f k v = k <> show v
    resultViaMapWithKey = m # M.mapWithKey f
    resultViaLists = m # M.toList # map (\(Tuple k v) → Tuple k (f k v)) # M.fromFoldable
    in resultViaMapWithKey === resultViaLists

  log "Bug #63: accidental observable mutation in foldMap"
  quickCheck \(TestStrMap m) ->
    let lhs = go m
        rhs = go m
    in lhs == rhs <?> ("lhs: " <> show lhs <> ", rhs: " <> show rhs)
    where
    go :: M.StrMap (Array Ordering) -> Array Ordering
    go = M.foldMap \_ v -> v

module Test.Data.StrMap where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Random (RANDOM)

import Data.Foldable (foldl)
import Data.Function (on)
import Data.List (List(..), groupBy, sortBy, singleton, fromFoldable, zipWith)
import Data.List.NonEmpty as NEL
import Data.Maybe (Maybe(..))
import Data.StrMap as M
import Data.Tuple (Tuple(..), fst)

import Partial.Unsafe (unsafePartial)

import Test.QuickCheck ((<?>), quickCheck, quickCheck', (===))
import Test.QuickCheck.Arbitrary (class Arbitrary, arbitrary)
import Test.QuickCheck.Gen as Gen

newtype TestStrMap v = TestStrMap (M.StrMap v)

instance arbTestStrMap :: (Arbitrary v) => Arbitrary (TestStrMap v) where
  arbitrary = TestStrMap <<< (M.fromFoldable :: List (Tuple String v) -> M.StrMap v) <$> arbitrary

data Instruction k v = Insert k v | Delete k

instance showInstruction :: (Show k, Show v) => Show (Instruction k v) where
  show (Insert k v) = "Insert (" <> show k <> ") (" <> show v <> ")"
  show (Delete k) = "Delete (" <> show k <> ")"

instance arbInstruction :: (Arbitrary v) => Arbitrary (Instruction String v) where
  arbitrary = do
    b <- arbitrary
    k <- Gen.frequency (Tuple 10.0 (pure "hasOwnProperty"))
                       (Tuple 50.0 arbitrary `Cons` Nil)
    case b of
      true -> do
        v <- arbitrary
        pure (Insert k v)
      false -> do
        pure (Delete k)

runInstructions :: forall v. List (Instruction String v) -> M.StrMap v -> M.StrMap v
runInstructions instrs t0 = foldl step t0 instrs
  where
  step tree (Insert k v) = M.insert k v tree
  step tree (Delete k) = M.delete k tree

number :: Int -> Int
number n = n

strMapTests :: forall eff. Eff (console :: CONSOLE, random :: RANDOM, err :: EXCEPTION | eff) Unit
strMapTests = do
  log "Test inserting into empty tree"
  quickCheck $ \k v -> M.lookup k (M.insert k v M.empty) == Just (number v)
    <?> ("k: " <> show k <> ", v: " <> show v)

  quickCheck $ \k v1 v2 ->
    M.lookup (smallKey k) (M.insert k v2 (M.insert k v1 M.empty)) == Just (number v2)

  log "Test delete after inserting"
  quickCheck $ \k v -> M.isEmpty (M.delete k (M.insert k (number v) M.empty))
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Test pop after inserting"
  quickCheck $ \k v -> M.pop k (M.insert k (number v) M.empty) == Just (Tuple v M.empty)
    <?> ("k: " <> show k <> ", v: " <> show v)

  log "Pop non-existent key"
  quickCheck $ \k1 k2 v -> k1 == k2 || M.pop k2 (M.insert k1 (number v) M.empty) == Nothing
    <?> ("k1: " <> show k1 <> ", k2: " <> show k2 <> ", v: " <> show v)

  log "Insert two, lookup first"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k1 (M.insert k2 (number v2) (M.insert k1 (number v1) M.empty)) == Just v1
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Insert two, lookup second"
  quickCheck $ \k1 v1 k2 v2 -> M.lookup k2 (M.insert k2 (number v2) (M.insert k1 (number v1) M.empty)) == Just v2
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Insert two, delete one"
  quickCheck $ \k1 v1 k2 v2 -> k1 == k2 || M.lookup k2 (M.delete k1 (M.insert k2 (number v2) (M.insert k1 (number v1) M.empty))) == Just v2
    <?> ("k1: " <> show k1 <> ", v1: " <> show v1 <> ", k2: " <> show k2 <> ", v2: " <> show v2)

  log "Lookup from empty"
  quickCheck $ \k -> M.lookup k (M.empty :: M.StrMap Int) == Nothing

  log "Lookup from singleton"
  quickCheck $ \k v -> M.lookup k (M.singleton k (v :: Int)) == Just v

  log "Random lookup"
  quickCheck' 1000 $ \instrs k v ->
    let
      tree :: M.StrMap Int
      tree = M.insert k v (runInstructions instrs M.empty)
    in M.lookup k tree == Just v <?> ("instrs:\n  " <> show instrs <> "\nk:\n  " <> show k <> "\nv:\n  " <> show v)

  log "Singleton to list"
  quickCheck $ \k v -> M.toList (M.singleton k v :: M.StrMap Int) == singleton (Tuple k v)

  log "fromFoldable [] = empty"
  quickCheck (M.fromFoldable [] == (M.empty :: M.StrMap Unit)
    <?> "was not empty")

  log "fromFoldable & key collision"
  do
    let nums = M.fromFoldable [Tuple "0" "zero", Tuple "1" "what", Tuple "1" "one"]
    quickCheck (M.lookup "0" nums == Just "zero" <?> "invalid lookup - 0")
    quickCheck (M.lookup "1" nums == Just "one"  <?> "invalid lookup - 1")
    quickCheck (M.lookup "2" nums == Nothing     <?> "invalid lookup - 2")

  log "fromFoldableWith const [] = empty"
  quickCheck (M.fromFoldableWith const [] == (M.empty :: M.StrMap Unit)
    <?> "was not empty")

  log "fromFoldableWith (+) & key collision"
  do
    let nums = M.fromFoldableWith (+) [Tuple "0" 1, Tuple "1" 1, Tuple "1" 1]
    quickCheck (M.lookup "0" nums == Just 1  <?> "invalid lookup - 0")
    quickCheck (M.lookup "1" nums == Just 2  <?> "invalid lookup - 1")
    quickCheck (M.lookup "2" nums == Nothing <?> "invalid lookup - 2")

  log "toList . fromFoldable = id"
  quickCheck $ \arr -> let f x = M.toList (M.fromFoldable x)
                       in f (f arr) == f (arr :: List (Tuple String Int)) <?> show arr

  log "fromFoldable . toList = id"
  quickCheck $ \(TestStrMap m) ->
    let f m1 = M.fromFoldable (M.toList m1) in
    M.toList (f m) == M.toList (m :: M.StrMap Int) <?> show m

  log "fromFoldableWith const = fromFoldable"
  quickCheck $ \arr -> M.fromFoldableWith const arr ==
                       M.fromFoldable (arr :: List (Tuple String Int)) <?> show arr

  log "fromFoldableWith (<>) = fromFoldable . collapse with (<>) . group on fst"
  quickCheck $ \arr ->
    let combine (Tuple s a) (Tuple t b) = (Tuple s $ b <> a)
        foldl1 g = unsafePartial \(Cons x xs) -> foldl g x xs
        f = M.fromFoldable <<< map (foldl1 combine <<< NEL.toList) <<<
            groupBy ((==) `on` fst) <<< sortBy (compare `on` fst) in
    M.fromFoldableWith (<>) arr == f (arr :: List (Tuple String String)) <?> show arr

  log "Lookup from union"
  quickCheck $ \(TestStrMap m1) (TestStrMap m2) k ->
    M.lookup k (M.union m1 m2) == (case M.lookup k m1 of
      Nothing -> M.lookup k m2
      Just v -> Just (number v)) <?> ("m1: " <> show m1 <> ", m2: " <> show m2 <> ", k: " <> show k <> ", v1: " <> show (M.lookup k m1) <> ", v2: " <> show (M.lookup k m2) <> ", union: " <> show (M.union m1 m2))

  log "Union is idempotent"
  quickCheck $ \(TestStrMap m1) (TestStrMap m2) ->
    (m1 `M.union` m2) == ((m1 `M.union` m2) `M.union` (m2 :: M.StrMap Int)) <?> (show (M.size (m1 `M.union` m2)) <> " != " <> show (M.size ((m1 `M.union` m2) `M.union` m2)))

  log "fromFoldable = zip keys values"
  quickCheck $ \(TestStrMap m) -> M.toList m == zipWith Tuple (fromFoldable $ M.keys m) (M.values m :: List Int)

  log "mapWithKey is correct"
  quickCheck $ \(TestStrMap m :: TestStrMap Int) -> let
    f k v = k <> show v
    resultViaMapWithKey = m # M.mapWithKey f
    resultViaLists = m # M.toList # map (\(Tuple k v) → Tuple k (f k v)) # M.fromFoldable
    in resultViaMapWithKey === resultViaLists

  log "Bug #63: accidental observable mutation in foldMap"
  quickCheck \(TestStrMap m) ->
    let lhs = go m
        rhs = go m
    in lhs == rhs <?> ("lhs: " <> show lhs <> ", rhs: " <> show rhs)
    where
    go :: M.StrMap (Array Ordering) -> Array Ordering
    go = M.foldMap \_ v -> v


Fix HTML for structure viewer layout

Fix HTML for structure viewer layout

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.StructureEditor.Column.Component where

import SlamData.Prelude

import Halogen as H
import Halogen.Component.Proxy (proxyQL)
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Query.HalogenM as HQ

import SlamData.Monad (Slam)
import SlamData.Workspace.Card.StructureEditor.Common (ColumnItem, ColumnPath)
import SlamData.Workspace.Card.StructureEditor.Message (Message)
import SlamData.Workspace.MillerColumns.Column.Component as MCC

type ColumnOptions = MCC.ColumnOptions ColumnItem ColumnPath Message
type ColumnQuery = MCC.Query ColumnItem ColumnPath Message

type Message' = MCC.Message' ColumnItem ColumnPath Message

component
  ∷ ColumnOptions
  → ColumnPath
  → H.Component HH.HTML (MCC.Query' ColumnItem ColumnPath Message) Input Message' Slam
component opts = proxyQL ∘ component' opts

data Query a = Raise Message' a

type Query' = Coproduct ColumnQuery Query

type State = MCC.ColumnWidth × Maybe ColumnItem

type Input = MCC.ColumnWidth × Maybe ColumnItem

type DSL = H.ParentDSL State Query' ColumnQuery Unit Message' Slam
type HTML = H.ParentHTML Query' ColumnQuery Unit Slam

component'
  ∷ ColumnOptions
  → ColumnPath
  → H.Component HH.HTML Query' Input Message' Slam
component' opts path =
  H.parentComponent
    { initialState: id
    , render
    , eval
    , receiver: Just ∘ left ∘ H.action ∘ MCC.HandleInput
    }
  where

  column ∷ H.Component HH.HTML ColumnQuery Input Message' Slam
  column = MCC.component' opts path

  render ∷ State → HTML
  render st =
    HH.div
      [ HP.class_ (HH.ClassName "sd-structure-editor-column") ]
      [ HH.slot unit column st (Just ∘ right ∘ H.action ∘ Raise) ]

  eval ∷ Query' ~> DSL
  eval = coproduct evalInner evalOuter

  evalInner ∷ ColumnQuery ~> DSL
  evalInner =
    maybe (HQ.halt "Inner component query failed") pure <=< H.query unit

  evalOuter ∷ Query ~> DSL
  evalOuter = case _ of
    Raise msg next → do
      H.raise msg
      pure next

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.StructureEditor.Column.Component where

import SlamData.Prelude

import Halogen as H
import Halogen.Component.Proxy (proxyQL)
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Query.HalogenM as HQ

import SlamData.Monad (Slam)
import SlamData.Workspace.Card.StructureEditor.Common (ColumnItem, ColumnPath)
import SlamData.Workspace.Card.StructureEditor.Message (Message)
import SlamData.Workspace.MillerColumns.Column.Component as MCC

type ColumnOptions = MCC.ColumnOptions ColumnItem ColumnPath Message
type ColumnQuery = MCC.Query ColumnItem ColumnPath Message

type Message' = MCC.Message' ColumnItem ColumnPath Message

component
  ∷ ColumnOptions
  → ColumnPath
  → H.Component HH.HTML (MCC.Query' ColumnItem ColumnPath Message) Input Message' Slam
component opts = proxyQL ∘ component' opts

data Query a = Raise Message' a

type Query' = Coproduct ColumnQuery Query

type State = MCC.ColumnWidth × Maybe ColumnItem

type Input = MCC.ColumnWidth × Maybe ColumnItem

type DSL = H.ParentDSL State Query' ColumnQuery Unit Message' Slam
type HTML = H.ParentHTML Query' ColumnQuery Unit Slam

component'
  ∷ ColumnOptions
  → ColumnPath
  → H.Component HH.HTML Query' Input Message' Slam
component' opts path =
  H.parentComponent
    { initialState: id
    , render
    , eval
    , receiver: Just ∘ left ∘ H.action ∘ MCC.HandleInput
    }
  where

  column ∷ H.Component HH.HTML ColumnQuery Input Message' Slam
  column = MCC.component' opts path

  render ∷ State → HTML
  render st =
    HH.div_
      [ HH.div
          [ HP.class_ (HH.ClassName "sd-structure-editor-column") ]
          [ HH.slot unit column st (Just ∘ right ∘ H.action ∘ Raise) ]
      ]

  eval ∷ Query' ~> DSL
  eval = coproduct evalInner evalOuter

  evalInner ∷ ColumnQuery ~> DSL
  evalInner =
    maybe (HQ.halt "Inner component query failed") pure <=< H.query unit

  evalOuter ∷ Query ~> DSL
  evalOuter = case _ of
    Raise msg next → do
      H.raise msg
      pure next