Remove dead code

Remove dead code

Original commit 068181215bc32281f5b366c23021aa4c921a74e4

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 M
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (camelCase, stringEscape, legalizeCharacters, startWithLetter)
import Data.Tuple (Tuple(..), fst)
import Utils (mapM, removeElement, sortByKeyM, sortByKey)

renderer :: Renderer
renderer =
    { name: "Go"
    , aceMode: "golang"
    , extension: "go"
    , doc: golangDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: []
        , topLevelName: forbidNamer goNameStyle (\n -> let gn = goNameStyle n in [gn, "Unmarshal" <> gn])
        , unions: Just
            { predicate: excludeNullablesUnionPredicate
            , properName: simpleNamer (goNameStyle <<< combineNames)
            , nameFromTypes: simpleNamer unionNameFromTypes
            }
        }
    }

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

unionNameFromTypes :: Array String -> String
unionNameFromTypes names =
    names
    <#> 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

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

renderNullableToGolang :: IRType -> Doc { rendered :: String, comment :: Maybe String }
renderNullableToGolang x = do
    { rendered, comment } <- renderTypeToGolang x
    pure
        if isValueType x then
            { rendered: "*" <> rendered, comment: Just $ maybe "optional" ("optional "<> _) comment }
        else
            { rendered, comment: Nothing }

renderUnionToGolang :: IRUnionRep -> Doc { rendered :: String, comment :: Maybe String }
renderUnionToGolang ur =
    case nullableFromSet $ unionToSet ur of
    Just x -> renderNullableToGolang x
    Nothing -> do
        noComment =<< lookupUnionName ur

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 types

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

goNameStyle :: String -> String
goNameStyle = legalizeCharacters isLetterCharacter >>> camelCase >>> startWithLetter isLetterCharacter true

golangDoc :: Doc Unit
golangDoc = do
    line "// To parse and unparse this JSON data, add this code to your project and do:"
    forTopLevel_ \topLevelName topLevelType -> do
        line "//"
        line $ "//    r, err := Unmarshal" <> topLevelName <> "(bytes)"
        line $ "//    bytes, err = r.Marshal()"
    blank
    line "package main"
    unions <- getUnions
    unless (unions == L.Nil) do
        line "import \"bytes\""
        line "import \"errors\""
    line "import \"encoding/json\""
    forTopLevel_ \topLevelName topLevelType -> do
        { rendered: renderedToplevel, comment: toplevelComment } <- renderTypeToGolang topLevelType
        blank
        line $ "type " <> topLevelName <> " " <> renderedToplevel <> (renderComment toplevelComment)
        blank
        line $ "func Unmarshal" <> topLevelName <> "(data []byte) (" <> topLevelName <> ", error) {"
        line $ "    var r " <> topLevelName
        line """    err := json.Unmarshal(data, &r)
    return r, err
}
"""
        line $ "func (r *" <> topLevelName <> ") Marshal() ([]byte, error) {"
        indent do
            line "return json.Marshal(r)"
        line "}"
    blank
    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 { names: propertyNames } = transformNames (simpleNamer goNameStyle) ("Other" <> _) S.empty $ map (\n -> Tuple n n) $ M.keys properties
    let propsList = M.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 :: IRUnionRep -> Doc Unit
renderGolangUnion ur = do
    name <- lookupUnionName ur
    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 } <- renderNullableToGolang t
        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
        allTypes = unionToSet ur
        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 M
import Data.Maybe (Maybe(..), isJust, maybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (camelCase, stringEscape, legalizeCharacters, startWithLetter)
import Data.Tuple (Tuple(..), fst)
import Utils (mapM, removeElement, sortByKeyM, sortByKey)

renderer :: Renderer
renderer =
    { name: "Go"
    , aceMode: "golang"
    , extension: "go"
    , doc: golangDoc
    , transforms:
        { nameForClass: simpleNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames: []
        , topLevelName: forbidNamer goNameStyle (\n -> let gn = goNameStyle n in [gn, "Unmarshal" <> gn])
        , unions: Just
            { predicate: excludeNullablesUnionPredicate
            , properName: simpleNamer (goNameStyle <<< combineNames)
            , nameFromTypes: simpleNamer unionNameFromTypes
            }
        }
    }

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

unionNameFromTypes :: Array String -> String
unionNameFromTypes names =
    names
    <#> 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

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

renderNullableToGolang :: IRType -> Doc { rendered :: String, comment :: Maybe String }
renderNullableToGolang x = do
    { rendered, comment } <- renderTypeToGolang x
    pure
        if isValueType x then
            { rendered: "*" <> rendered, comment: Just $ maybe "optional" ("optional "<> _) comment }
        else
            { rendered, comment: Nothing }

renderUnionToGolang :: IRUnionRep -> Doc { rendered :: String, comment :: Maybe String }
renderUnionToGolang ur =
    case nullableFromSet $ unionToSet ur of
    Just x -> renderNullableToGolang x
    Nothing -> do
        noComment =<< lookupUnionName ur

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 types

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

goNameStyle :: String -> String
goNameStyle = legalizeCharacters isLetterCharacter >>> camelCase >>> startWithLetter isLetterCharacter true

golangDoc :: Doc Unit
golangDoc = do
    line "// To parse and unparse this JSON data, add this code to your project and do:"
    forTopLevel_ \topLevelName topLevelType -> do
        line "//"
        line $ "//    r, err := Unmarshal" <> topLevelName <> "(bytes)"
        line $ "//    bytes, err = r.Marshal()"
    blank
    line "package main"
    unions <- getUnions
    unless (unions == L.Nil) do
        line "import \"bytes\""
        line "import \"errors\""
    line "import \"encoding/json\""
    forTopLevel_ \topLevelName topLevelType -> do
        { rendered: renderedToplevel, comment: toplevelComment } <- renderTypeToGolang topLevelType
        blank
        line $ "type " <> topLevelName <> " " <> renderedToplevel <> (renderComment toplevelComment)
        blank
        line $ "func Unmarshal" <> topLevelName <> "(data []byte) (" <> topLevelName <> ", error) {"
        line $ "    var r " <> topLevelName
        line """    err := json.Unmarshal(data, &r)
    return r, err
}
"""
        line $ "func (r *" <> topLevelName <> ") Marshal() ([]byte, error) {"
        indent do
            line "return json.Marshal(r)"
        line "}"
    blank
    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 { names: propertyNames } = transformNames (simpleNamer goNameStyle) ("Other" <> _) S.empty $ map (\n -> Tuple n n) $ M.keys properties
    let propsList = M.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 :: IRUnionRep -> Doc Unit
renderGolangUnion ur = do
    name <- lookupUnionName ur
    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 } <- renderNullableToGolang t
        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
        allTypes = unionToSet ur
        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


Break into two description blocks

Break into two description blocks

module Test.Main where

import Prelude
import Debug.Trace
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Trans (lift)
import qualified Text.Parsing.Parser as P
import qualified Docopt.Parser.Docopt as Docopt
import qualified Docopt.Textwrap as Textwrap
import qualified Docopt.Parser.Lexer as Lexer
import qualified Docopt.Parser.Scanner as Scanner
import Docopt.Parser.Base (debug)
import Data.Either (either)

import Test.Spec (describe, it)
import Test.Spec.Runner (run)
import Test.Spec.Reporter.Console (consoleReporter)

main = run [consoleReporter] do
  describe "docopt scanner" do
    it "breaks apart the input" do
      either
        (throwError <<< error <<< show)
        (traceShowA)
        (Scanner.scanDocopt
          """
          Naval Fate.

          Usage:
          naval_fate -xvzf FIle
          """
        )
    it "lexes usages" do
      either
        (throwError <<< error <<< show)
        (traceShowA)
        (flip P.runParser Lexer.parseTokens $ Textwrap.dedent
        """
        naval_fate -xvzf FIle
        """
        )
  describe "docopt lexer" do
    it "lexes options" do
      either
        (throwError <<< error <<< show)
        (traceShowA)
        (flip P.runParser Lexer.parseTokens $ Textwrap.dedent
        """
        -h --help     Show this screen.
        --version     Show version.
        --speed=<kn>  Speed in knots [default: 10].
        --moored      Moored (anchored) mine.
        --drifting    Drifting mine.
        """
        )

module Test.Main where

import Prelude
import Debug.Trace
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Trans (lift)
import qualified Text.Parsing.Parser as P
import qualified Docopt.Parser.Docopt as Docopt
import qualified Docopt.Textwrap as Textwrap
import qualified Docopt.Parser.Lexer as Lexer
import qualified Docopt.Parser.Scanner as Scanner
import Docopt.Parser.Base (debug)
import Data.Either (either)

import Test.Spec (describe, it)
import Test.Spec.Runner (run)
import Test.Spec.Reporter.Console (consoleReporter)

main = run [consoleReporter] do
  describe "docopt scanner" do
    it "breaks apart the input" do
      either
        (throwError <<< error <<< show)
        (traceShowA)
        (Scanner.scanDocopt
          """
          Naval Fate.

          Usage:
          naval_fate -xvzf FIle
          """
        )
    it "lexes usages" do
      either
        (throwError <<< error <<< show)
        (traceShowA)
        (flip P.runParser Lexer.parseTokens $ Textwrap.dedent
        """
        naval_fate -xvzf FIle
        """
        )
    it "lexes options" do
      either
        (throwError <<< error <<< show)
        (traceShowA)
        (flip P.runParser Lexer.parseTokens $ Textwrap.dedent
        """
        -h --help     Show this screen.
        --version     Show version.
        --speed=<kn>  Speed in knots [default: 10].
        --moored      Moored (anchored) mine.
        --drifting    Drifting mine.
        """
        )


Start for submitNewTodo

Start for submitNewTodo

So, how do I use getRefs?! It seems like I need to universally qualify the
`forall a. ReactRefs a` type to a record that contains a `newField` with a
DOMProps containery thing. Phew.

module Main where

import Control.Monad.Eff
import Debug.Trace (trace, Trace())
import Data.Array (map)
import React
import React.DOM

enterKeyCode :: Number
enterKeyCode = 13

todoHeader = mkUI spec do
  pure $ header [ idProp "header" ]
    [ h1' [ text "todos" ]
    , input
      [ idProp "new-todo"
      , ref "newField"
      , placeholder "What needs to be done?"
      , autoFocus "true"
      , onKeyDown submitNewTodo
      ] []
    ]
  where
    submitNewTodo :: forall a b. KeyboardEvent -> Eff (trace :: Trace, refs :: ReactRefs b | a) Unit
    submitNewTodo e = do
      refs <- getRefs
      -- TODO: UGLY!! guard? Control.Monad.when?
      if e.keyCode == enterKeyCode
         then trace "hi"
         else pure unit

exampleItems =
  [ { id: 0
    , todo: "Go to Paris"
    , editing: false
    , completed: true
    },
    { id: 1
    , todo: "Write PureScript TodoMVC"
    , editing: false
    , completed: false
    },
    { id: 2
    , todo: "Find the Hotel"
    , editing: true
    , completed: false
    }
  ]

todoList = mkUI spec do
    props <- getProps
    let todoItems = (\i ->
      let checked' = if i.completed then "checked" else ""
          class' = if i.completed then "completed" else "" in
        li [ className class' ]
          [ div [ className "view" ]
            [ input
                [ className "toggle"
                , typeProp "checkbox"
                , checked checked'
                ] []
            , label' [ text i.todo ]
            ]
          , input
            [ className "edit"
            , value i.todo
            ] []
          ]) <$> props.items
    pure $ ul [ idProp "todo-list" ] todoItems

todoMain = mkUI spec {
    getInitialState = return { items: exampleItems }
  } do
    state <- readState
    pure $ section [ idProp "main" ]
      [ input
        [ idProp "toggle-all"
        , typeProp "checkbox"
        ] []
        , todoList { items: state.items }
      ]

todoFooter = mkUI spec do
  pure $ footer [ idProp "footer" ]
    [ span [ idProp "todo-count" ]
      [ strong' [ text "0" ]
      , text " item(s) left"
      ]
    ]

-- Only temporarily
renderUI el = mkUI spec el []

main :: Eff (dom :: React.DOM) React.UI
main = do
  renderToElementById "todoapp" $ renderUI do
    pure $ div'
      [ todoHeader []
      , todoMain []
      , todoFooter []
      ]

module Main where

import Control.Monad.Eff
import Debug.Trace (trace)
import Data.Array (map)
import React
import React.DOM

todoHeader = mkUI spec do
  pure $ header [ idProp "header" ]
    [ h1' [ text "todos" ]
    , input
      [ idProp "new-todo"
      , placeholder "What needs to be done?"
      , autoFocus "true"
      ] []
    ]

exampleItems =
  [ { id: 0
    , todo: "Go to Paris"
    , editing: false
    , completed: true
    },
    { id: 1
    , todo: "Write PureScript TodoMVC"
    , editing: false
    , completed: false
    },
    { id: 2
    , todo: "Find the Hotel"
    , editing: true
    , completed: false
    }
  ]

todoList = mkUI spec do
    props <- getProps
    let todoItems = (\i ->
      let checked' = if i.completed then "checked" else ""
          class' = if i.completed then "completed" else "" in
        li [ className class' ]
          [ div [ className "view" ]
            [ input
                [ className "toggle"
                , typeProp "checkbox"
                , checked checked'
                ] []
            , label' [ text i.todo ]
            ]
          , input
            [ className "edit"
            , value i.todo
            ] []
          ]) <$> props.items
    pure $ ul [ idProp "todo-list" ] todoItems

todoMain = mkUI spec {
    getInitialState = return { items: exampleItems }
  } do
    state <- readState
    pure $ section [ idProp "main" ]
      [ input
        [ idProp "toggle-all"
        , typeProp "checkbox"
        ] []
        , todoList { items: state.items }
      ]

todoFooter = mkUI spec do
  pure $ footer [ idProp "footer" ]
    [ span [ idProp "todo-count" ]
      [ strong' [ text "0" ]
      , text " item(s) left"
      ]
    ]

-- Only temporarily
renderUI el = mkUI spec el []

main :: Eff (dom :: React.DOM) React.UI
main = do
  renderToElementById "todoapp" $ renderUI do
    pure $ div'
      [ todoHeader []
      , todoMain []
      , todoFooter []
      ]


Add functions to angular module

Add functions to angular module

module Angular where

import Control.Monad.Eff

import Angular.Injector (Injector())
import Angular.Element (Element())

-- | bind

foreign import bootstrap
  " function bootstrap(element) { \
  \   return function(modules){ \
  \     return function(){ \
  \       return angular.bootstrap(element, modules); \
  \     }; \
  \   }; \
  \ }"
  :: forall e. Element -> [String] -> Eff e Injector

foreign import copy
  " function copy(src) { \
  \   return function() { \
  \     return angular.copy(src); \
  \   }; \
  \ }" :: forall e a. a -> Eff e a

-- | element => Angular.Element

-- | equals

foreign import extend
  " function extend(dst) { \
  \   return function(src) { \
  \     return function() { \
  \       return angular.extend(dst, src); \
  \     }; \
  \   }; \
  \ }" :: forall e a b c. { | a } -> { | b } -> Eff e { | c }

-- | forEach

-- | fromJson

-- | identity

-- | injector, see Angular.Injector

foreign import isArray
  " function isArray(value) { \
  \   return function() { \
  \     return angular.isArray(value); \
  \   }; \
  \ }" :: forall e a. a -> Eff e Boolean

foreign import isDate
  " function isDate(value) { \
  \   return function() { \
  \     return angular.isDate(value); \
  \   }; \
  \ }" :: forall e a. a -> Eff e Boolean

foreign import isDefined
  " function isDefined(value) { \
  \   return function() { \
  \     return angular.isDefined(value); \
  \   }; \
  \ }" :: forall e a. a -> Eff e Boolean

foreign import isElement
  " function isElement(value) { \
  \   return function() { \
  \     return angular.isElement(value); \
  \   }; \
  \ }" :: forall e a. a -> Eff e Boolean

foreign import isFunction
  " function isFunction(value) { \
  \   return function() { \
  \     return angular.isFunction(value); \
  \   }; \
  \ }" :: forall e a. a -> Eff e Boolean

foreign import isNumber
  " function isNumber(value) { \
  \   return function() { \
  \     return angular.isNumber(value); \
  \   }; \
  \ }" :: forall e a. a -> Eff e Boolean

foreign import isObject
  " function isObject(value) { \
  \   return function() { \
  \     return angular.isObject(value); \
  \   }; \
  \ }" :: forall e a. a -> Eff e Boolean

foreign import isString
  " function isString(value) { \
  \   return function() { \
  \     return angular.isString(value); \
  \   }; \
  \ }" :: forall e a. a -> Eff e Boolean

foreign import isUndefined
  " function isUndefined(value) { \
  \   return function() { \
  \     return angular.isUndefined(value); \
  \   }; \
  \ }" :: forall e a. a -> Eff e Boolean

foreign import lowercase
  " function lowercase(str) { \
  \   return function() { \
  \     return angular.lowercase(str); \
  \   }; \
  \ }" :: forall e. String -> Eff e String

-- | module => Angular.Module

-- | noop

-- | toJson

-- | uppercase

module Angular where

import Control.Monad.Eff

import Angular.Injector (Injector())
import Angular.Element (Element())

-- | bind

foreign import bootstrap
  " function bootstrap(element) { \
  \   return function(modules){ \
  \     return function(){ \
  \       return angular.bootstrap(element, modules); \
  \     }; \
  \   }; \
  \ }"
  :: forall e. Element -> [String] -> Eff e Injector

foreign import copy
  " function copy(src) { \
  \   return function() { \
  \     return angular.copy(src); \
  \   }; \
  \ }" :: forall e a. a -> Eff e a

-- | element => Angular.Element

-- | equals

foreign import extend
  " function extend(dst) { \
  \   return function(src) { \
  \     return function() { \
  \       return angular.extend(dst, src); \
  \     }; \
  \   }; \
  \ }" :: forall e a b c. { | a } -> { | b } -> Eff e { | c }

-- | forEach

-- | fromJson

-- | identity

-- | injector, see Angular.Injector

-- | isArray

-- | isDate

-- | isDefined

-- | isElement

-- | isFunction

-- | isNumber

-- | isObject

-- | isString

-- | isUndefined

-- | lowercase

-- | module => Angular.Module

-- | noop

-- | toJson

-- | uppercase


Unify showing zipper cases and regular cases

module Zippers where

import Prelude

import Control.Apply (lift2)
import Control.Comonad (class Comonad)
import Control.Comonad.Cofree (Cofree)
import Control.Comonad.Env (EnvT(..))
import Control.Extend (class Extend)
import Data.Bifunctor (bimap, lmap)
import Data.Const (Const(..))
import Data.Either (Either(..), either)
import Data.Foldable (foldr)
import Data.Function (on)
import Data.Functor.Compose (Compose(..))
import Data.Functor.Coproduct (Coproduct, left, right)
import Data.Functor.Product (Product(..), product)
import Data.Functor.Variant (VariantF)
import Data.Functor.Variant as VF
import Data.Identity (Identity)
import Data.Lazy (Lazy, defer, force)
import Data.Lens (Lens', lens, (^.))
import Data.List.Lazy (List, nil, uncons, (:))
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid.Additive (Additive)
import Data.Newtype (unwrap, wrap)
import Data.Pair (Pair(..))
import Data.StrMap (StrMap)
import Data.StrMap as StrMap
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Tuple (Tuple(..), fst, uncurry)
import Data.Variant.Internal (FProxy(..), RLProxy(..))
import Matryoshka (class Corecursive, class Recursive, Algebra, cata, embed, project)
import Recursion (Alg)
import Test.QuickCheck (class Arbitrary, class Coarbitrary, arbitrary, coarbitrary)
import Type.Row (class ListToRow, class RowToList, Cons, Nil, kind RowList)
import Types (ATypeV, ATypeVF, Ident, Proper, Qualified, _app, _fun, _name, _var)
import Unsafe.Coerce (unsafeCoerce)

type Tag = Tuple (Additive Int) (Additive Int)
type ATypeVC = Cofree ATypeVF Tag

class (Functor f, Functor f') <= Diff1 f f' | f -> f' where
  upF   :: forall x. ZF f x  ->       f x
  downF :: forall x.    f x  -> f (ZF f x)

downFTrivial ::
  forall f x.
    Functor f =>
    Diff1 f (Const Unit) =>
  f x -> f (ZF f x)
downFTrivial = map (pure (toDF (Const unit)) :<-: _)
upFTrivial ::
  forall f x.
    Applicative f =>
    Diff1 f (Const Unit) =>
  ZF f x -> f x
upFTrivial = (_ ^. _focusF) >>> pure

aroundF :: forall f f' f'' x. Diff1 f f' => Diff1 f' f'' => ZF f x  -> ZF f (ZF f x)
aroundF z@(c :<-: f) =
  (_ :<-: z) $ defer \_ ->toDF $
    downF (fromDF (force c)) <#> upZ
  where
    upZ :: ZF f' x -> ZF f x
    upZ z'@(_ :<-: x) = pure (toDF (upF z')) :<-: x

instance derivativeEnvT :: (Functor f, Diff1 f f') => Diff1 (EnvT e f) (EnvT e f') where
  downF (EnvT (Tuple e f)) = EnvT $ Tuple e $ downF f <#>
    injZF (EnvT <<< Tuple e)
  upF (dex :<-: x) =
    case fromDF (force dex) of
      EnvT (Tuple e dfx) ->
        EnvT $ Tuple e $ upF (pure (toDF' (FProxy :: FProxy f) dfx) :<-: x)

foreign import data DF :: (Type -> Type) -> Type -> Type
toDF' :: forall f f' x. Diff1 f f' => FProxy f -> f' x -> DF f x
toDF' _ = toDF
toDF :: forall f f' x. Diff1 f f' => f' x -> DF f x
toDF = unsafeCoerce
fromDF :: forall f f' x. Diff1 f f' => DF f x -> f' x
fromDF = unsafeCoerce
reDF :: forall f g f' x. Diff1 f f' => Diff1 g f' => DF f x -> DF g x
reDF = fromDF >>> toDF
reDF' :: forall f g f' x. Diff1 f f' => Diff1 g f' => FProxy g -> DF f x -> DF g x
reDF' p = fromDF >>> toDF' p
injDF :: forall f f' g x. Diff1 f f' => Diff1 (g f) (g f') =>
  (forall a. a ~> g a) -> DF f x -> DF (g f) x
injDF g = fromDF >>> g >>> toDF
liftDF :: forall f f' g g' x. Diff1 f f' => Diff1 g g' => (f' x -> g' x) -> DF f x -> DF g x
liftDF fg = fromDF >>> fg >>> toDF

instance functorDF :: Diff1 f f' => Functor (DF f) where
  map f = fromDF >>> map f >>> toDF

instance arbitraryDF :: ( Diff1 f f', Arbitrary (f' x), Arbitrary x ) => Arbitrary (DF f x) where
  arbitrary = toDF <$> arbitrary
instance coarbitraryDF :: ( Diff1 f f', Coarbitrary (f' x), Coarbitrary x ) => Coarbitrary (DF f x) where
  coarbitrary = fromDF >>> coarbitrary
instance eqDF :: ( Diff1 f f', Eq (f' x), Eq x ) => Eq (DF f x) where
  eq = eq `on` fromDF

data ZF f x = ZF (Lazy (DF f x)) x
infix 1 ZF as :<-:
toZF :: forall f f' x. Diff1 f f' => Tuple (f' x) x -> ZF f x
toZF (Tuple f'x x) = pure (toDF f'x) :<-: x
fromZF :: forall f f' x. Diff1 f f' => ZF f x -> Tuple (f' x) x
fromZF (f'x :<-: x) = Tuple (fromDF (force f'x)) x
reZF :: forall f g f' x. Diff1 f f' => Diff1 g f' => ZF f x -> ZF g x
reZF (f'x :<-: x) = reDF <$> f'x :<-: x
reZF' :: forall f g f' x. Diff1 f f' => Diff1 g f' => FProxy g -> ZF f x -> ZF g x
reZF' p (f'x :<-: x) = reDF' p <$> f'x :<-: x
injZF :: forall f f' g x. Diff1 f f' => Diff1 (g f) (g f') =>
  (forall a. a ~> g a) -> ZF f x -> ZF (g f) x
injZF g (f'x :<-: x) = injDF g <$> f'x :<-: x
injZF2 :: forall f f' g x. Diff1 f f' => Diff1 (g f) (g f') =>
  (forall a. a ~> g a) -> ZF f (ZF f x) -> ZF (g f) (ZF (g f) x)
injZF2 g (f'x :<-: x) = f'x <#> (injDF g >>> map (injZF g)) :<-: injZF g x
liftZF :: forall f f' g g' x. Diff1 f f' => Diff1 g g' => (f' x -> g' x) -> ZF f x -> ZF g x
liftZF fg (f'x :<-: x) = liftDF fg <$> f'x :<-: x

_contextF :: forall f x. Lens' (ZF f x) (Lazy (DF f x))
_contextF = lens (\(c :<-: _) -> c)
  \(_ :<-: f) c -> c :<-: f

_focusF :: forall f x. Lens' (ZF f x) x
_focusF = lens (\(_ :<-: f) -> f)
  \(c :<-: _) f -> c :<-: f

instance functorZF :: Diff1 f f' => Functor (ZF f) where
  map f (f'x :<-: x) = map f <$> f'x :<-: f x
instance extendZF :: (Diff1 f f', Diff1 f' f'') => Extend (ZF f) where
  extend f = map f <<< aroundF
instance comonadZF :: (Diff1 f f', Diff1 f' f'') => Comonad (ZF f) where
  extract (_ :<-: x) = x

instance arbitraryZF :: ( Diff1 f f', Arbitrary (f' x), Arbitrary x ) => Arbitrary (ZF f x) where
  arbitrary = lift2 ZF arbitrary arbitrary
instance coarbitraryZF :: ( Diff1 f f', Coarbitrary (f' x), Coarbitrary x ) => Coarbitrary (ZF f x) where
  coarbitrary (c :<-: f) = coarbitrary c <<< coarbitrary f
instance eqZF :: ( Diff1 f f', Eq (f' x), Eq x ) => Eq (ZF f x) where
  eq (c1 :<-: f1) (c2 :<-: f2) = eq c1 c2 && eq f1 f2

ixPair :: forall a b. (Boolean -> a -> b) -> Pair a -> Pair b
ixPair f (Pair l r) = Pair (f false l) (f true r)

ixDPair :: forall a. DPair a -> Boolean
ixDPair = fst

instance derivativeofTuple_keepsA :: Diff1 (Tuple a) (Const a) where
  downF (Tuple a b) = Tuple a $ pure (toDF (Const a)) :<-: b
  upF (a :<-: b) = Tuple (unwrap $ fromDF $ force a) b

type DPair = Tuple Boolean
instance derivativeofPair_isDPair :: Diff1 Pair (Tuple Boolean) where
  downF (Pair l r) = Pair
    (pure (toDF (Tuple false r)) :<-: l)
    (pure (toDF (Tuple true  l)) :<-: r)
  upF (c :<-: x) = case fromDF (force c), x of
    Tuple false r, l -> Pair l r
    Tuple true  l, r -> Pair l r

type DStrMap = Compose (Tuple String) StrMap
instance derivativeofStrMap_isDStrMap :: Diff1 StrMap (Compose (Tuple String) StrMap) where
  downF sm = sm # StrMap.mapWithKey \k v -> (_ :<-: v) $ defer \_ ->
    toDF (Compose (Tuple k (StrMap.delete k sm)))
  upF (c :<-: v) = case fromDF $ force c of
    Compose (Tuple k sm) ->
      StrMap.insert k v sm

instance derivativeofConst_isVoid :: Diff1 (Const a) (Const Void) where
  downF (Const a) = Const a
  upF (c :<-: _) = absurd $ unwrap $ fromDF $ force c

instance derivativeofIdentity_isUnit :: Diff1 Identity (Const Unit) where
  downF f = downFTrivial f
  upF z = upFTrivial z
instance derivativeofMaybe_isUnit :: Diff1 Maybe (Const Unit) where
  downF f = downFTrivial f
  upF z = upFTrivial z
instance derivativeofEither_isUnit :: Diff1 (Either e) (Const Unit) where
  downF f = downFTrivial f
  upF z = upFTrivial z

instance chainRule :: ( Functor f, Diff1 f f', Functor g, Diff1 g g' ) =>
  Diff1 (Compose f g) (Product (Compose f' g) g') where
  downF (Compose fg) = Compose $ downF fg <#> \(f'g :<-: g) ->
    downF g <#> liftZF \x ->
      product (Compose (fromDF (force f'g))) x
  upF (c :<-: x) = case lmap unwrap (unwrap (fromDF (force c))) of
    Tuple f'g g' -> Compose $ upF $ pure (toDF f'g) :<-:
      upF (pure (toDF g') :<-: x)

instance derivativeofCoproduct :: ( Functor f, Diff1 f f', Functor g, Diff1 g g' ) =>
  Diff1 (Coproduct f g) (Coproduct f' g') where
  downF = unwrap >>> bimap
    (downF >>> map (liftZF \f' -> left f'))
    (downF >>> map (liftZF \g' -> right g')) >>> wrap
  upF (c :<-: x) = case unwrap (fromDF (force c)) of
    Left  f' -> left  (upF (pure (toDF f') :<-: x))
    Right g' -> right (upF (pure (toDF g') :<-: x))

instance derivativeofProduct :: ( Functor f, Diff1 f f', Functor g, Diff1 g g' ) =>
  Diff1 (Product f g) (Coproduct (Product f' g) (Product f g')) where
  upF (c :<-: x) = case bimap unwrap unwrap (unwrap (fromDF (force c))) of
    Left (Tuple f' g) -> product
      (upF (pure (toDF f') :<-: x))
      (g)
    Right (Tuple f g') -> product
      (f)
      (upF (pure (toDF g') :<-: x))
  downF (Product (Tuple f g)) = product
    (downF f <#> liftZF \f' -> left  (product f' g))
    (downF g <#> liftZF \g' -> right (product f g'))

instance deriveofVariant_isVariantOfDerivatives ::
  ( RowToList r rl
  , DiffVariantF r r' rl rl'
  , ListToRow rl' r'
  ) => Diff1 (VariantF r) (VariantF r') where
  downF = map (uncurry ZF <<< lmap (map toDF)) <<< downV (RLProxy :: RLProxy rl)
  upF (v :<-: x) = upV (RLProxy :: RLProxy rl) (Tuple (map fromDF v) x)

type VF r' a = Tuple (Lazy (VariantF r' a)) a

class DiffVariantF (r :: # Type) (r' :: # Type) (rl :: RowList) (rl' :: RowList) | rl -> r r' rl' where
  upV :: forall a. RLProxy rl -> VF r' a -> VariantF r a
  downV :: forall a. RLProxy rl -> VariantF r a -> VariantF r (VF r' a)

instance diffVNil :: DiffVariantF () () Nil Nil where
  upV _ = fst >>> force >>> VF.case_
  downV _ = VF.case_

instance diffVCons ::
  ( IsSymbol sym
  , Functor f
  , Diff1 f f'
  , RowCons sym (FProxy f) n r
  , ListToRow rl n
  , DiffVariantF n n' rl rl'
  , RowToList n' rl'
  , RowCons sym (FProxy f') n' r'
  , Union n m r
  , Union n' m' r'
  ) => DiffVariantF r r' (Cons sym (FProxy f) rl) (Cons sym (FProxy f') rl') where
    upV _ (Tuple v x) = handleThis handleOther $ force v
      where
        sym = SProxy :: SProxy sym
        handleOther v' = VF.expand $
          upV (RLProxy :: RLProxy rl) (Tuple (pure v') x)
        handleThis = VF.on sym \f' ->
          VF.inj sym $ upF $
            pure (toDF' (FProxy :: FProxy f) f') :<-: x
    downV _ = handleThis handleOther
      where
        sym = SProxy :: SProxy sym
        handleOther v' = VF.expand $ lmap (map VF.expand) <$>
          downV (RLProxy :: RLProxy rl) v'
        handleThis = VF.on sym \f -> VF.inj sym $ downF f <#>
          \(c :<-: f') -> Tuple (defer \_ -> VF.inj sym (fromDF (force c))) f'

type ParentCtx t = DF (Alg t) t
type ParentCtxs t = List (ParentCtx t)
data ZRec t = ZRec (ParentCtxs t) t
infix 1 ZRec as :<<~:

toParentCtx ::
  forall t f f'.
    Recursive t f =>
    Corecursive t f =>
    Diff1 f f' =>
  DF f ~> DF (Alg t)
toParentCtx = unsafeCoerce

fromParentCtx ::
  forall t f f'.
    Recursive t f =>
    Corecursive t f =>
    Diff1 f f' =>
  DF (Alg t) ~> DF f
fromParentCtx = unsafeCoerce

downRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  ZRec t -> f (ZRec t)
downRec (context :<<~: focus) = downF (project focus) <#>
  case _ of
    cx :<-: fc ->
      toParentCtx (force cx) : context :<<~: fc

upRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  ZRec t -> Either t (ZRec t)
upRec (cxs :<<~: focus) =
  case uncons cxs of
    Nothing -> Left focus
    Just { head: cx, tail: context } -> Right $
      context :<<~: embed (upF (pure (fromParentCtx cx) :<-: focus))

tipRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  t -> ZRec t
tipRec = ZRec nil

topRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  ZRec t -> t
topRec z = upRec z # either id topRec

downIntoRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  (f ~> Maybe) -> ZRec t -> ZRec t
downIntoRec f z = maybe z id (f (downRec z))

_contextRec :: forall t. Lens' (ZRec t) (List (DF (Alg t) t))
_contextRec = lens (\(c :<<~: _) -> c)
  \(_ :<<~: f) c -> c :<<~: f

_focusRec :: forall t. Lens' (ZRec t) t
_focusRec = lens (\(_ :<<~: f) -> f)
  \(c :<<~: _) f -> c :<<~: f

type ZipperVRec = ZRec ATypeVC

handleATypeVFByTypes :: forall a r.
  { "Const" :: forall b. Const b a -> r
  , "Pair" :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVFByTypes methods = handleATypeVF
  { name: methods."Const"
  , var: methods."Const"
  , fun: methods."Pair"
  , app: methods."Pair"
  }

handleATypeVFPairs :: forall a r.
  { name :: Const (Qualified Proper) a -> r
  , var :: Const Ident a -> r
  , "Pair" :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVFPairs methods = handleATypeVF
  { name: methods.name
  , var: methods.var
  , fun: methods."Pair"
  , app: methods."Pair"
  }

handleATypeVFConsts :: forall a r.
  { "Const" :: forall b. Const b a -> r
  , fun :: Pair a -> r
  , app :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVFConsts methods = handleATypeVF
  { name: methods."Const"
  , var: methods."Const"
  , fun: methods.fun
  , app: methods.app
  }

handleATypeVF :: forall a r.
  { name :: Const (Qualified Proper) a -> r
  , var :: Const Ident a -> r
  , fun :: Pair a -> r
  , app :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVF methods = VF.case_
  # VF.on _name methods.name
  # VF.on _var methods.var
  # VF.on _fun methods.fun
  # VF.on _app methods.app

handleATypeVFReinjector :: forall a r.
  { "Const" :: forall b.
      (Const b ~> ATypeVF) ->
      (DF (Const b) ~> DF ATypeVF) ->
      Const b a -> r
  , "Pair" ::
      (Pair ~> ATypeVF) ->
      (DF Pair ~> DF ATypeVF) ->
      Pair a -> r
  } -> ATypeVF a -> r
handleATypeVFReinjector methods = VF.case_
  # VF.on _name (methods."Const" (VF.inj _name) (fromDF >>> unwrap >>> absurd))
  # VF.on _var (methods."Const" (VF.inj _var) (fromDF >>> unwrap >>> absurd))
  # VF.on _fun (methods."Pair" (VF.inj _fun) (fromDF >>> VF.inj _fun >>> toDF))
  # VF.on _app (methods."Pair" (VF.inj _app) (fromDF >>> VF.inj _app >>> toDF))

cataZRec ::
  forall t f f' a.
    Recursive t f =>
    Corecursive t f =>
    Diff1 f f' =>
  Algebra f a -> ZRec t -> a
cataZRec alg (context :<<~: focus) = foldr go (cata alg focus) context where
  go h a = alg $ upF $ pure (cata alg <$> fromParentCtx h) :<-: a

simpleShowZRec :: ZRec ATypeV -> String
simpleShowZRec = cataZRec show1
  where
    show1 :: Algebra ATypeVF String
    show1 = VF.match
      { name: unwrap >>> show
      , var: unwrap >>> show
      , fun: \(Pair l r) ->
          "(" <> l <> ") -> (" <> r <> ")"
      , app: \(Pair l r) ->
          "(" <> l <> ") (" <> r <> ")"
      }

module Zippers where

import Prelude

import Control.Apply (lift2)
import Control.Comonad (class Comonad)
import Control.Comonad.Cofree (Cofree)
import Control.Comonad.Env (EnvT(..))
import Control.Extend (class Extend)
import Data.Bifunctor (bimap, lmap)
import Data.Const (Const(..))
import Data.Either (Either(..), either)
import Data.Function (on)
import Data.Functor.Compose (Compose(..))
import Data.Functor.Coproduct (Coproduct, left, right)
import Data.Functor.Product (Product(..), product)
import Data.Functor.Variant (VariantF)
import Data.Functor.Variant as VF
import Data.Identity (Identity)
import Data.Lazy (Lazy, defer, force)
import Data.Lens (Lens', lens, (^.))
import Data.List.Lazy (List, nil, uncons, (:))
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid.Additive (Additive)
import Data.Newtype (unwrap, wrap)
import Data.Pair (Pair(..))
import Data.StrMap (StrMap)
import Data.StrMap as StrMap
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Tuple (Tuple(..), fst, uncurry)
import Data.Variant.Internal (FProxy(..), RLProxy(..))
import Matryoshka (class Corecursive, class Recursive, Algebra, cata, embed, project)
import Recursion (Alg)
import Test.QuickCheck (class Arbitrary, class Coarbitrary, arbitrary, coarbitrary)
import Type.Row (class ListToRow, class RowToList, Cons, Nil, kind RowList)
import Types (ATypeV, ATypeVF, Ident, Proper, Qualified, _app, _fun, _name, _var)
import Unsafe.Coerce (unsafeCoerce)

type Tag = Tuple (Additive Int) (Additive Int)
type ATypeVC = Cofree ATypeVF Tag

class (Functor f, Functor f') <= Diff1 f f' | f -> f' where
  upF   :: forall x. ZF f x  ->       f x
  downF :: forall x.    f x  -> f (ZF f x)

downFTrivial ::
  forall f x.
    Functor f =>
    Diff1 f (Const Unit) =>
  f x -> f (ZF f x)
downFTrivial = map (pure (toDF (Const unit)) :<-: _)
upFTrivial ::
  forall f x.
    Applicative f =>
    Diff1 f (Const Unit) =>
  ZF f x -> f x
upFTrivial = (_ ^. _focusF) >>> pure

aroundF :: forall f f' f'' x. Diff1 f f' => Diff1 f' f'' => ZF f x  -> ZF f (ZF f x)
aroundF z@(c :<-: f) =
  (_ :<-: z) $ defer \_ ->toDF $
    downF (fromDF (force c)) <#> upZ
  where
    upZ :: ZF f' x -> ZF f x
    upZ z'@(_ :<-: x) = pure (toDF (upF z')) :<-: x

instance derivativeEnvT :: (Functor f, Diff1 f f') => Diff1 (EnvT e f) (EnvT e f') where
  downF (EnvT (Tuple e f)) = EnvT $ Tuple e $ downF f <#>
    injZF (EnvT <<< Tuple e)
  upF (dex :<-: x) =
    case fromDF (force dex) of
      EnvT (Tuple e dfx) ->
        EnvT $ Tuple e $ upF (pure (toDF' (FProxy :: FProxy f) dfx) :<-: x)

foreign import data DF :: (Type -> Type) -> Type -> Type
toDF' :: forall f f' x. Diff1 f f' => FProxy f -> f' x -> DF f x
toDF' _ = toDF
toDF :: forall f f' x. Diff1 f f' => f' x -> DF f x
toDF = unsafeCoerce
fromDF :: forall f f' x. Diff1 f f' => DF f x -> f' x
fromDF = unsafeCoerce
reDF :: forall f g f' x. Diff1 f f' => Diff1 g f' => DF f x -> DF g x
reDF = fromDF >>> toDF
reDF' :: forall f g f' x. Diff1 f f' => Diff1 g f' => FProxy g -> DF f x -> DF g x
reDF' p = fromDF >>> toDF' p
injDF :: forall f f' g x. Diff1 f f' => Diff1 (g f) (g f') =>
  (forall a. a ~> g a) -> DF f x -> DF (g f) x
injDF g = fromDF >>> g >>> toDF
liftDF :: forall f f' g g' x. Diff1 f f' => Diff1 g g' => (f' x -> g' x) -> DF f x -> DF g x
liftDF fg = fromDF >>> fg >>> toDF

instance functorDF :: Diff1 f f' => Functor (DF f) where
  map f = fromDF >>> map f >>> toDF

instance arbitraryDF :: ( Diff1 f f', Arbitrary (f' x), Arbitrary x ) => Arbitrary (DF f x) where
  arbitrary = toDF <$> arbitrary
instance coarbitraryDF :: ( Diff1 f f', Coarbitrary (f' x), Coarbitrary x ) => Coarbitrary (DF f x) where
  coarbitrary = fromDF >>> coarbitrary
instance eqDF :: ( Diff1 f f', Eq (f' x), Eq x ) => Eq (DF f x) where
  eq = eq `on` fromDF

data ZF f x = ZF (Lazy (DF f x)) x
infix 1 ZF as :<-:
toZF :: forall f f' x. Diff1 f f' => Tuple (f' x) x -> ZF f x
toZF (Tuple f'x x) = pure (toDF f'x) :<-: x
fromZF :: forall f f' x. Diff1 f f' => ZF f x -> Tuple (f' x) x
fromZF (f'x :<-: x) = Tuple (fromDF (force f'x)) x
reZF :: forall f g f' x. Diff1 f f' => Diff1 g f' => ZF f x -> ZF g x
reZF (f'x :<-: x) = reDF <$> f'x :<-: x
reZF' :: forall f g f' x. Diff1 f f' => Diff1 g f' => FProxy g -> ZF f x -> ZF g x
reZF' p (f'x :<-: x) = reDF' p <$> f'x :<-: x
injZF :: forall f f' g x. Diff1 f f' => Diff1 (g f) (g f') =>
  (forall a. a ~> g a) -> ZF f x -> ZF (g f) x
injZF g (f'x :<-: x) = injDF g <$> f'x :<-: x
injZF2 :: forall f f' g x. Diff1 f f' => Diff1 (g f) (g f') =>
  (forall a. a ~> g a) -> ZF f (ZF f x) -> ZF (g f) (ZF (g f) x)
injZF2 g (f'x :<-: x) = f'x <#> (injDF g >>> map (injZF g)) :<-: injZF g x
liftZF :: forall f f' g g' x. Diff1 f f' => Diff1 g g' => (f' x -> g' x) -> ZF f x -> ZF g x
liftZF fg (f'x :<-: x) = liftDF fg <$> f'x :<-: x

_contextF :: forall f x. Lens' (ZF f x) (Lazy (DF f x))
_contextF = lens (\(c :<-: _) -> c)
  \(_ :<-: f) c -> c :<-: f

_focusF :: forall f x. Lens' (ZF f x) x
_focusF = lens (\(_ :<-: f) -> f)
  \(c :<-: _) f -> c :<-: f

instance functorZF :: Diff1 f f' => Functor (ZF f) where
  map f (f'x :<-: x) = map f <$> f'x :<-: f x
instance extendZF :: (Diff1 f f', Diff1 f' f'') => Extend (ZF f) where
  extend f = map f <<< aroundF
instance comonadZF :: (Diff1 f f', Diff1 f' f'') => Comonad (ZF f) where
  extract (_ :<-: x) = x

instance arbitraryZF :: ( Diff1 f f', Arbitrary (f' x), Arbitrary x ) => Arbitrary (ZF f x) where
  arbitrary = lift2 ZF arbitrary arbitrary
instance coarbitraryZF :: ( Diff1 f f', Coarbitrary (f' x), Coarbitrary x ) => Coarbitrary (ZF f x) where
  coarbitrary (c :<-: f) = coarbitrary c <<< coarbitrary f
instance eqZF :: ( Diff1 f f', Eq (f' x), Eq x ) => Eq (ZF f x) where
  eq (c1 :<-: f1) (c2 :<-: f2) = eq c1 c2 && eq f1 f2

ixPair :: forall a b. (Boolean -> a -> b) -> Pair a -> Pair b
ixPair f (Pair l r) = Pair (f false l) (f true r)

ixDPair :: forall a. DPair a -> Boolean
ixDPair = fst

instance derivativeofTuple_keepsA :: Diff1 (Tuple a) (Const a) where
  downF (Tuple a b) = Tuple a $ pure (toDF (Const a)) :<-: b
  upF (a :<-: b) = Tuple (unwrap $ fromDF $ force a) b

type DPair = Tuple Boolean
instance derivativeofPair_isDPair :: Diff1 Pair (Tuple Boolean) where
  downF (Pair l r) = Pair
    (pure (toDF (Tuple false r)) :<-: l)
    (pure (toDF (Tuple true  l)) :<-: r)
  upF (c :<-: x) = case fromDF (force c), x of
    Tuple false r, l -> Pair l r
    Tuple true  l, r -> Pair l r

type DStrMap = Compose (Tuple String) StrMap
instance derivativeofStrMap_isDStrMap :: Diff1 StrMap (Compose (Tuple String) StrMap) where
  downF sm = sm # StrMap.mapWithKey \k v -> (_ :<-: v) $ defer \_ ->
    toDF (Compose (Tuple k (StrMap.delete k sm)))
  upF (c :<-: v) = case fromDF $ force c of
    Compose (Tuple k sm) ->
      StrMap.insert k v sm

instance derivativeofConst_isVoid :: Diff1 (Const a) (Const Void) where
  downF (Const a) = Const a
  upF (c :<-: _) = absurd $ unwrap $ fromDF $ force c

instance derivativeofIdentity_isUnit :: Diff1 Identity (Const Unit) where
  downF f = downFTrivial f
  upF z = upFTrivial z
instance derivativeofMaybe_isUnit :: Diff1 Maybe (Const Unit) where
  downF f = downFTrivial f
  upF z = upFTrivial z
instance derivativeofEither_isUnit :: Diff1 (Either e) (Const Unit) where
  downF f = downFTrivial f
  upF z = upFTrivial z

instance chainRule :: ( Functor f, Diff1 f f', Functor g, Diff1 g g' ) =>
  Diff1 (Compose f g) (Product (Compose f' g) g') where
  downF (Compose fg) = Compose $ downF fg <#> \(f'g :<-: g) ->
    downF g <#> liftZF \x ->
      product (Compose (fromDF (force f'g))) x
  upF (c :<-: x) = case lmap unwrap (unwrap (fromDF (force c))) of
    Tuple f'g g' -> Compose $ upF $ pure (toDF f'g) :<-:
      upF (pure (toDF g') :<-: x)

instance derivativeofCoproduct :: ( Functor f, Diff1 f f', Functor g, Diff1 g g' ) =>
  Diff1 (Coproduct f g) (Coproduct f' g') where
  downF = unwrap >>> bimap
    (downF >>> map (liftZF \f' -> left f'))
    (downF >>> map (liftZF \g' -> right g')) >>> wrap
  upF (c :<-: x) = case unwrap (fromDF (force c)) of
    Left  f' -> left  (upF (pure (toDF f') :<-: x))
    Right g' -> right (upF (pure (toDF g') :<-: x))

instance derivativeofProduct :: ( Functor f, Diff1 f f', Functor g, Diff1 g g' ) =>
  Diff1 (Product f g) (Coproduct (Product f' g) (Product f g')) where
  upF (c :<-: x) = case bimap unwrap unwrap (unwrap (fromDF (force c))) of
    Left (Tuple f' g) -> product
      (upF (pure (toDF f') :<-: x))
      (g)
    Right (Tuple f g') -> product
      (f)
      (upF (pure (toDF g') :<-: x))
  downF (Product (Tuple f g)) = product
    (downF f <#> liftZF \f' -> left  (product f' g))
    (downF g <#> liftZF \g' -> right (product f g'))

instance deriveofVariant_isVariantOfDerivatives ::
  ( RowToList r rl
  , DiffVariantF r r' rl rl'
  , ListToRow rl' r'
  ) => Diff1 (VariantF r) (VariantF r') where
  downF = map (uncurry ZF <<< lmap (map toDF)) <<< downV (RLProxy :: RLProxy rl)
  upF (v :<-: x) = upV (RLProxy :: RLProxy rl) (Tuple (map fromDF v) x)

type VF r' a = Tuple (Lazy (VariantF r' a)) a

class DiffVariantF (r :: # Type) (r' :: # Type) (rl :: RowList) (rl' :: RowList) | rl -> r r' rl' where
  upV :: forall a. RLProxy rl -> VF r' a -> VariantF r a
  downV :: forall a. RLProxy rl -> VariantF r a -> VariantF r (VF r' a)

instance diffVNil :: DiffVariantF () () Nil Nil where
  upV _ = fst >>> force >>> VF.case_
  downV _ = VF.case_

instance diffVCons ::
  ( IsSymbol sym
  , Functor f
  , Diff1 f f'
  , RowCons sym (FProxy f) n r
  , ListToRow rl n
  , DiffVariantF n n' rl rl'
  , RowToList n' rl'
  , RowCons sym (FProxy f') n' r'
  , Union n m r
  , Union n' m' r'
  ) => DiffVariantF r r' (Cons sym (FProxy f) rl) (Cons sym (FProxy f') rl') where
    upV _ (Tuple v x) = handleThis handleOther $ force v
      where
        sym = SProxy :: SProxy sym
        handleOther v' = VF.expand $
          upV (RLProxy :: RLProxy rl) (Tuple (pure v') x)
        handleThis = VF.on sym \f' ->
          VF.inj sym $ upF $
            pure (toDF' (FProxy :: FProxy f) f') :<-: x
    downV _ = handleThis handleOther
      where
        sym = SProxy :: SProxy sym
        handleOther v' = VF.expand $ lmap (map VF.expand) <$>
          downV (RLProxy :: RLProxy rl) v'
        handleThis = VF.on sym \f -> VF.inj sym $ downF f <#>
          \(c :<-: f') -> Tuple (defer \_ -> VF.inj sym (fromDF (force c))) f'

type ParentCtx t = DF (Alg t) t
type ParentCtxs t = List (ParentCtx t)
data ZRec t = ZRec (ParentCtxs t) t
infix 1 ZRec as :<<~:

toParentCtx ::
  forall t f f'.
    Recursive t f =>
    Corecursive t f =>
    Diff1 f f' =>
  DF f ~> DF (Alg t)
toParentCtx = unsafeCoerce

fromParentCtx ::
  forall t f f'.
    Recursive t f =>
    Corecursive t f =>
    Diff1 f f' =>
  DF (Alg t) ~> DF f
fromParentCtx = unsafeCoerce

downRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  ZRec t -> f (ZRec t)
downRec (context :<<~: focus) = downF (project focus) <#>
  case _ of
    cx :<-: fc ->
      toParentCtx (force cx) : context :<<~: fc

upRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  ZRec t -> Either t (ZRec t)
upRec (cxs :<<~: focus) =
  case uncons cxs of
    Nothing -> Left focus
    Just { head: cx, tail: context } -> Right $
      context :<<~: embed (upF (pure (fromParentCtx cx) :<-: focus))

tipRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  t -> ZRec t
tipRec = ZRec nil

topRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  ZRec t -> t
topRec z = upRec z # either id topRec

downIntoRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  (f ~> Maybe) -> ZRec t -> ZRec t
downIntoRec f z = maybe z id (f (downRec z))

_contextRec :: forall t. Lens' (ZRec t) (List (DF (Alg t) t))
_contextRec = lens (\(c :<<~: _) -> c)
  \(_ :<<~: f) c -> c :<<~: f

_focusRec :: forall t. Lens' (ZRec t) t
_focusRec = lens (\(_ :<<~: f) -> f)
  \(c :<<~: _) f -> c :<<~: f

type ZipperVRec = ZRec ATypeVC

handleATypeVFByTypes :: forall a r.
  { "Const" :: forall b. Const b a -> r
  , "Pair" :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVFByTypes methods = handleATypeVF
  { name: methods."Const"
  , var: methods."Const"
  , fun: methods."Pair"
  , app: methods."Pair"
  }

handleATypeVFPairs :: forall a r.
  { name :: Const (Qualified Proper) a -> r
  , var :: Const Ident a -> r
  , "Pair" :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVFPairs methods = handleATypeVF
  { name: methods.name
  , var: methods.var
  , fun: methods."Pair"
  , app: methods."Pair"
  }

handleATypeVFConsts :: forall a r.
  { "Const" :: forall b. Const b a -> r
  , fun :: Pair a -> r
  , app :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVFConsts methods = handleATypeVF
  { name: methods."Const"
  , var: methods."Const"
  , fun: methods.fun
  , app: methods.app
  }

handleATypeVF :: forall a r.
  { name :: Const (Qualified Proper) a -> r
  , var :: Const Ident a -> r
  , fun :: Pair a -> r
  , app :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVF methods = VF.case_
  # VF.on _name methods.name
  # VF.on _var methods.var
  # VF.on _fun methods.fun
  # VF.on _app methods.app

handleATypeVFReinjector :: forall a r.
  { "Const" :: forall b.
      (Const b ~> ATypeVF) ->
      (DF (Const b) ~> DF ATypeVF) ->
      Const b a -> r
  , "Pair" ::
      (Pair ~> ATypeVF) ->
      (DF Pair ~> DF ATypeVF) ->
      Pair a -> r
  } -> ATypeVF a -> r
handleATypeVFReinjector methods = VF.case_
  # VF.on _name (methods."Const" (VF.inj _name) (fromDF >>> unwrap >>> absurd))
  # VF.on _var (methods."Const" (VF.inj _var) (fromDF >>> unwrap >>> absurd))
  # VF.on _fun (methods."Pair" (VF.inj _fun) (fromDF >>> VF.inj _fun >>> toDF))
  # VF.on _app (methods."Pair" (VF.inj _app) (fromDF >>> VF.inj _app >>> toDF))

simpleShowZRec :: ZRec ATypeV -> String
simpleShowZRec (context :<<~: focus) = go context cx
  where
    show1 :: Algebra ATypeVF String
    show1 = VF.match
      { name: unwrap >>> show
      , var: unwrap >>> show
      , fun: \(Pair l r) ->
          "(" <> l <> ") -> (" <> r <> ")"
      , app: \(Pair l r) ->
          "(" <> l <> ") (" <> r <> ")"
      }
    showAll = cata show1
    cx = showAll focus
    go ls s = case uncons ls of
      Nothing -> s
      Just { head: h, tail: r } -> go r $ VF.match
        { fun: showBranch " -> " s
        , app: showBranch " " s
        , name: unwrap >>> absurd
        , var: unwrap >>> absurd
        } $ fromDF $ fromParentCtx h
    showBranch :: String -> String -> DPair ATypeV -> String
    showBranch sep s (Tuple false a) = "{" <> s <> "}" <> sep <> showAll a
    showBranch sep s (Tuple true a) = showAll a <> sep <> "{" <> s <> "}"


d3Remove shouldn't return anything

d3Remove shouldn't return anything

module Graphics.D3.Raw.Selection
  ( Selection()
  , d3Select
  , d3SelectAll
  , d3SelectFrom
  , d3SelectAllFrom
  , d3SetData
  , d3Enter
  , d3Exit
  , d3Transition
  , d3Append
  , d3Remove
  , d3SetAttr
  ) where

import Graphics.D3.Base
import Control.Monad.Eff

foreign import data Selection :: *

foreign import d3Select
  "function d3Select(selector) {\
  \  return function () {\
  \    return d3.select(selector);\
  \  };\
  \}"
  :: forall e. String -> D3Eff e Selection

foreign import d3SelectAll
  "function d3SelectAll(selector) {\
  \  return function () {\
  \    return d3.selectAll(selector);\
  \  };\
  \}"
  :: forall e. String -> D3Eff e Selection

foreign import d3SelectFrom
  "function d3SelectFrom(selector) {\
  \  return function (selection) {\
  \    return function () {\
  \      return selection.select(selector);\
  \    };\
  \  };\
  \}"
  :: forall e. String -> Selection -> D3Eff e Selection

foreign import d3SelectAllFrom
  "function d3SelectAllFrom(selector) {\
  \  return function (selection) {\
  \    return function () {\
  \      return selection.selectAll(selector);\
  \    };\
  \  };\
  \}"
  :: forall e. String -> Selection -> D3Eff e Selection

foreign import d3SetData
  "function d3SetData(data) {\
  \  return function (selection) {\
  \    return function () {\
  \      return selection.data(data);\
  \    };\
  \  };\
  \}"
  :: forall d e. [d] -> Selection -> D3Eff e Selection

foreign import d3Enter
  "function d3Enter(selection) {\
  \  return function () {\
  \    return selection.enter();\
  \  };\
  \}"
  :: forall e. Selection -> D3Eff e Selection

foreign import d3Exit
  "function d3Exit(selection) {\
  \  return function () {\
  \    return selection.exit();\
  \  };\
  \}"
  :: forall e. Selection -> D3Eff e Selection

foreign import d3Transition
  "function d3Transition(selection) {\
  \  return function () {\
  \    return selection.transition();\
  \  };\
  \}"
  :: forall e. Selection -> D3Eff e Selection

foreign import d3Append
  "function d3Append(tag) {\
  \  return function (selection) {\
  \    return function () {\
  \      return selection.append(tag);\
  \    };\
  \  };\
  \}"
  :: forall e. String -> Selection -> D3Eff e Selection

foreign import d3Remove
  "function d3Remove(selection) {\
  \  return function () {\
  \    selection.remove();\
  \  };\
  \}"
  :: forall e. Selection -> D3Eff e Unit

foreign import d3SetAttr
  "function d3SetAttr(key) {\
  \  return function (val) {\
  \    return function (selection) {\
  \      return function () {\
  \        selection.attr(key, val);\
  \      };\
  \    };\
  \  };\
  \}"
  :: forall a e. String -> a -> Selection -> D3Eff e Unit

module Graphics.D3.Raw.Selection
  ( Selection()
  , d3Select
  , d3SelectAll
  , d3SelectFrom
  , d3SelectAllFrom
  , d3SetData
  , d3Enter
  , d3Exit
  , d3Transition
  , d3Append
  , d3Remove
  , d3SetAttr
  ) where

import Graphics.D3.Base
import Control.Monad.Eff

foreign import data Selection :: *

foreign import d3Select
  "function d3Select(selector) {\
  \  return function () {\
  \    return d3.select(selector);\
  \  };\
  \}"
  :: forall e. String -> D3Eff e Selection

foreign import d3SelectAll
  "function d3SelectAll(selector) {\
  \  return function () {\
  \    return d3.selectAll(selector);\
  \  };\
  \}"
  :: forall e. String -> D3Eff e Selection

foreign import d3SelectFrom
  "function d3SelectFrom(selector) {\
  \  return function (selection) {\
  \    return function () {\
  \      return selection.select(selector);\
  \    };\
  \  };\
  \}"
  :: forall e. String -> Selection -> D3Eff e Selection

foreign import d3SelectAllFrom
  "function d3SelectAllFrom(selector) {\
  \  return function (selection) {\
  \    return function () {\
  \      return selection.selectAll(selector);\
  \    };\
  \  };\
  \}"
  :: forall e. String -> Selection -> D3Eff e Selection

foreign import d3SetData
  "function d3SetData(data) {\
  \  return function (selection) {\
  \    return function () {\
  \      return selection.data(data);\
  \    };\
  \  };\
  \}"
  :: forall d e. [d] -> Selection -> D3Eff e Selection

foreign import d3Enter
  "function d3Enter(selection) {\
  \  return function () {\
  \    return selection.enter();\
  \  };\
  \}"
  :: forall e. Selection -> D3Eff e Selection

foreign import d3Exit
  "function d3Exit(selection) {\
  \  return function () {\
  \    return selection.exit();\
  \  };\
  \}"
  :: forall e. Selection -> D3Eff e Selection

foreign import d3Transition
  "function d3Transition(selection) {\
  \  return function () {\
  \    return selection.transition();\
  \  };\
  \}"
  :: forall e. Selection -> D3Eff e Selection

foreign import d3Append
  "function d3Append(tag) {\
  \  return function (selection) {\
  \    return function () {\
  \      return selection.append(tag);\
  \    };\
  \  };\
  \}"
  :: forall e. String -> Selection -> D3Eff e Selection

foreign import d3Remove
  "function d3Remove(selection) {\
  \  return function () {\
  \    return selection.remove();\
  \  };\
  \}"
  :: forall e. Selection -> D3Eff e Unit

foreign import d3SetAttr
  "function d3SetAttr(key) {\
  \  return function (val) {\
  \    return function (selection) {\
  \      return function () {\
  \        selection.attr(key, val);\
  \      };\
  \    };\
  \  };\
  \}"
  :: forall a e. String -> a -> Selection -> D3Eff e Unit


Add imperfect tense

Add imperfect tense

module Table where

import Prelude
import UIHelpers
import DOM.Event.Event as Event
import DOM.HTML.HTMLInputElement as HInput
import Data.Array as Array
import Data.Maybe as Maybe
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import MDL as MDL
import MDL.Layout as Layout
import CSS.TextAlign (leftTextAlign, textAlign)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import DOM (DOM)
import DOM.Event.Types (Event, MouseEvent)
import DOM.HTML.Types (HTMLInputElement)
import Data.Foldable (maximum)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Tuple (Tuple(..))
import Data.Typelevel.Num (class Nat, D2, D5)
import Data.Vector (Vec, empty, toArray, (+>))
import Debug.Trace (spy)
import Global.Unsafe (unsafeStringify)
import Halogen.HTML.CSS (style)
import Unsafe.Coerce (unsafeCoerce)

data Query a
    = ToggleState a
    | UserInput Event a

type Inflection nRows nCols cell =
    { rowLabels :: Vec nRows String
    , colLabels :: Vec nCols String
    , cells :: Vec nRows (Vec nCols cell)
    }

type Declension cell = Inflection D5 D2 cell
type Noun = Declension String

class Show d <= Display d where
    display :: forall a b. d -> HH.HTML a b

instance unitLabel :: Display Unit where
    display _ = HH.text ""

instance emptyLabel :: Display Void where
    display _ = HH.text ""

instance identityDisplay :: Display String where
    display = HH.text

newtype TableSection sectionT majRT minRT majCT minCT dataT =
    TableSection
        { section :: sectionT
        , rows :: Headers majRT minRT
        , cols :: Headers majCT minCT
        , getCell :: sectionT -> majRT -> minRT -> majCT -> minCT -> dataT
        }

instance showTableSection :: (
    Show sectionT, Show majRT, Show minRT, Show majCT, Show minCT, Show dataT
) => Show (TableSection sectionT majRT minRT majCT minCT dataT) where
    show (TableSection { section, rows, cols, getCell }) =
        unsafeStringify
            { section: show section
            , rows: map showHeader rows
            , cols: map showHeader cols
            }
        where
            showHeader :: forall a b. (Show a, Show b) => Header a b -> String
            showHeader { label, sub: [] } =
                show label
            showHeader { label, sub } =
                show label <> " " <> show sub

{-
instance showTableSection :: Show (TableSection Unit Degree minRT majCT minCT dataT) where
    show (TableSection { section, rows, cols, getCell }) =
        show $ map showHeader rows
        where
            showHeader { label } = show label
-}

newtype CompoundTable sectionT majRT minRT majCT minCT dataT
    = CompoundTable (Array (TableSection sectionT majRT minRT majCT minCT dataT))

instance showTable :: (
    Show sectionT, Show majRT, Show minRT, Show majCT, Show minCT, Show dataT
) => Show (CompoundTable sectionT majRT minRT majCT minCT dataT) where
    show (CompoundTable t) = show t

--instance showTable :: Show (CompoundTable Unit Degree minRT majCT minCT dataT) where show (CompoundTable t) = show t

simpleTable :: forall majRT minRT majCT minCT dataT.
    { rows :: Headers majRT minRT
    , cols :: Headers majCT minCT
    , getCell :: majRT -> minRT -> majCT -> minCT -> dataT
    } -> CompoundTable Unit majRT minRT majCT minCT dataT
simpleTable { rows, cols, getCell } =
    { section: unit
    , rows: rows
    , cols: cols
    , getCell: const getCell
    } # TableSection # Array.singleton # CompoundTable

simpleVertical :: forall majRT minRT majCT minCT dataT.
    { rows :: Array majRT
    , getCell :: majRT -> dataT
    } -> CompoundTable Unit majRT minRT majCT minCT dataT
simpleVertical { rows, getCell } =
    { section: unit
    , rows: fullRows
    , cols: []
    , getCell: \_ row _ _ _ -> getCell row
    } # TableSection # Array.singleton # CompoundTable
    where
        fullRows =
            map (\label -> { label, sub: [] }) rows

type Header majT minT =
    { label :: majT
    , sub :: Array minT
    }
type Headers majT minT = Array (Header majT minT)

computeGutterWidth :: forall sectionT majRT minRT majCT minCT dataT
     . CompoundTable sectionT majRT minRT majCT minCT dataT
    -> Int
computeGutterWidth (CompoundTable sections) =
    sections # map (\(TableSection { rows }) ->
        if Array.null rows then 0
        else if Array.all (_.sub >>> Array.null) rows
        then 1 else 2
    ) # maximum # fromMaybe 0

mcons :: forall a. Maybe a -> Array a -> Array a
mcons (Just head) tail = Array.cons head tail
mcons Nothing tail = tail

instance displayTable :: (
    Display sectionT, Display majRT, Display minRT, Display majCT, Display minCT, Display dataT
) => Display (CompoundTable sectionT majRT minRT majCT minCT dataT) where
    display ctable@(CompoundTable [TableSection section]) =
        HH.table_><HH.tbody_ $ map HH.tr_ rows
        where
            gutterWidth = computeGutterWidth ctable
            cell a
                | gutterWidth == 0 = Nothing
                | otherwise =
                    Just $ HH.th [ HP.colSpan gutterWidth ] a
            mkMajRowH contents
                | gutterWidth == 0 =
                    HH.th_ >< contents
                | otherwise =
                    HH.th [ HP.colSpan gutterWidth ] >< contents
            labelCellM = cell [ display section.section ]
            padCellM = cell $ []
            headerMajCols =
                section.cols # map (\{ label, sub } ->
                    HH.th [ HP.colSpan $ max 1 $ Array.length sub ] >< display label
                )
            header = mcons labelCellM headerMajCols
            subcol2s =
                section.cols # Array.concatMap (\{ label, sub } ->
                    map (Tuple label) sub
                )
            continue majRow minRow =
                subcol2s # map (\(Tuple majCol minCol) ->
                    HH.td_ >< display $ section.getCell section.section majRow minRow majCol minCol
                )
            subheaderM =
                if Array.any (\{ sub } -> not $ Array.null sub) section.cols
                then
                    section.cols # Array.concatMap (\{ sub } ->
                        case sub of
                            [] ->
                                [ HH.th_ [] ]
                            _ ->
                                map (\h -> HH.th_ >< display h) sub
                    ) # Just
                else Nothing
            headerrows =
                case subheaderM of
                    Nothing -> [ header ]
                    Just subheader ->
                        [ header, mcons padCellM subheader ]
            simplerows =
                Array.all (\{ sub } -> Array.null sub) section.cols
            contentrows =
                section.rows # Array.concatMap mkrow
            mkrow { label, sub } =
                if simplerows
                then
                    [ mcons padCellM [ HH.th_ [ display label ] ] ]
                else
                    let
                        subrows = map (\sublabel -> [ HH.th_ [], HH.th_ [ display sublabel ] ] <> continue label sublabel) sub
                    in [ [ mkMajRowH $ display label ] ] <> subrows
            rows = headerrows <> contentrows
    display _ = display "table"

{-
computeCellWidths :: forall majT minT. Header majT minT -> Header (majT, Int) (minT, Int)

let
    labelCell = case computeGutterWidth table of
        0 -> Nothing
        1 -> Just $ H.th_ $ display section.section
        width -> Just $ H.th [ HA.colspan width ] $ display section.section
    header =

in mcons labelCell header
-}

nomen :: Noun
nomen =
    { rowLabels: "nom" +> "gen" +> "dat" +> "acc" +> "abl" +> empty
    , colLabels: "sg" +> "pl" +> empty
    , cells:
        ( "nomen" +> "nomina" +> empty ) +>
        ( "nominis" +> "nominum" +> empty) +>
        ( "nomini" +> "nominibus" +> empty) +>
        ( "nomen" +> "nomina" +> empty) +>
        ( "nomine" +> "nominibus" +> empty) +>
        empty
    }

data Degree = Positive | Comparative | Superlative
instance showDegree :: Show Degree where
    show Positive = "positive"
    show Comparative = "comparative"
    show Superlative = "superlative"
instance displayDegree :: Display Degree where
    display = display <<< show

data Person = FirstP | SecondP | ThirdP
instance showPerson :: Show Person where
    show FirstP = "1st person"
    show SecondP = "2nd person"
    show ThirdP = "3rd person"
instance displayPerson :: Display Person where
    display = display <<< show

data Number2 = Singular | Plural
instance showNumber2 :: Show Number2 where
    show Singular = "singular"
    show Plural = "plural"
instance displayNumber2 :: Display Number2 where
    display = display <<< show

data Tense = Present | Imperfect | Future | Perfect | Pluperfect | FuturePerfect
instance showTense :: Show Tense where
    show Present = "present"
    show Imperfect = "imperfect"
    show Future = "future"
    show Perfect = "perfect"
    show Pluperfect = "pluperfect"
    show FuturePerfect = "future-perfect"
instance displayTense :: Display Tense where
    display = display <<< show

data Voice = Active | Passive
instance showVoice :: Show Voice where
    show Active = "active"
    show Passive = "passive"
instance displayVoice :: Display Voice where
    display = display <<< show

data Mood = Indicative | Subjunctive
instance showMood :: Show Mood where
    show Indicative = "indicative"
    show Subjunctive = "subjunctive"
instance displayMood :: Display Mood where
    display = display <<< show

celeriter :: CompoundTable Unit Degree Void Void Void String
celeriter = simpleVertical
    { rows: [Positive, Comparative, Superlative]
    , getCell: case _ of
        Positive -> "celeriter"
        Comparative -> "celerius"
        Superlative -> "celerrimē"
    }

headerproduct :: forall majT minT. Array majT -> Array minT -> Headers majT minT
headerproduct major minor =
    map (\label -> { label, sub: minor }) major

getCellVolo :: Mood -> Voice -> Tense -> Number2 -> Person -> String
getCellVolo Indicative Active Present Singular FirstP = "volo"
getCellVolo Indicative Active Present Singular SecondP = "vīs"
getCellVolo Indicative Active Present Singular ThirdP = "volunt"
getCellVolo Indicative Active Present Plural FirstP = "volumus"
getCellVolo Indicative Active Present Plural SecondP = "vultis"
getCellVolo Indicative Active Present Plural ThirdP = "volunt"
getCellVolo Indicative Active Imperfect Singular FirstP = "volēbam"
getCellVolo Indicative Active Imperfect Singular SecondP = "volēbās"
getCellVolo Indicative Active Imperfect Singular ThirdP = "volēbat"
getCellVolo Indicative Active Imperfect Plural FirstP = "volēbāmus"
getCellVolo Indicative Active Imperfect Plural SecondP = "volēbātis"
getCellVolo Indicative Active Imperfect Plural ThirdP = "volēbant"
getCellVolo _ _ _ _ _ = "UNK"

volo :: CompoundTable Mood Voice Tense Number2 Person String
volo = CompoundTable ([TableSection
    { section: Indicative
    , rows: headerproduct [Active] [Present, Imperfect]
    , cols: headerproduct [Singular, Plural] [FirstP, SecondP, ThirdP]
    , getCell: getCellVolo
    }])

type State =
    { on :: Boolean
    , text :: String
    }

initialState :: State
initialState =
    { on: false
    , text: "Hello"
    }

table :: forall cell nRows nCols a b. (Nat nRows, Nat nCols)
    => Inflection nRows nCols cell
    -> (cell -> HH.HTML a b)
    -> HH.HTML a b
table datable mapper = HH.table_><HH.tbody_ (map HH.tr_ (Array.cons header rows))
    where
      header = Array.cons (HH.th_/> "") $ map (HH.th[style (textAlign leftTextAlign)]/> _) $ toArray datable.colLabels
      labels = toArray datable.rowLabels
      label i = Maybe.fromMaybe "" $ Array.index labels i
      rows =
        Array.mapWithIndex rowOf $ toArray datable.cells
      rowOf i cells =
        Array.cons (HH.th_/> label i) (map mapper $ toArray cells)

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

  render :: State -> H.ComponentHTML Query
  render state =
    mdiv1 Layout.container
    ><mdiv [ MDL.layout ]
      [ mdiv1 Layout.content
        ><table nomen (input (HE.input UserInput) [] "Form of nomen" >>> (HH.td_><_))
      , mdiv1 Layout.content>< display volo
      ]

  eval :: Query ~> H.ComponentDSL State Query Void (Aff (dom :: DOM | eff))
  eval (ToggleState next) = do
    H.modify (\state -> { on: not state.on, text: "Bye" })
    pure next
  eval (UserInput e next) = do
    let node = unsafeCoerce Event.target e :: HTMLInputElement
    s <- H.liftEff (HInput.value node :: Eff (dom :: DOM | eff) String)
    H.modify (\state -> { on: state.on, text: s })
    pure next

module Table where

import Prelude
import UIHelpers
import DOM.Event.Event as Event
import DOM.HTML.HTMLInputElement as HInput
import Data.Array as Array
import Data.Maybe as Maybe
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import MDL as MDL
import MDL.Layout as Layout
import CSS.TextAlign (leftTextAlign, textAlign)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import DOM (DOM)
import DOM.Event.Types (Event, MouseEvent)
import DOM.HTML.Types (HTMLInputElement)
import Data.Foldable (maximum)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Tuple (Tuple(..))
import Data.Typelevel.Num (class Nat, D2, D5)
import Data.Vector (Vec, empty, toArray, (+>))
import Debug.Trace (spy)
import Global.Unsafe (unsafeStringify)
import Halogen.HTML.CSS (style)
import Unsafe.Coerce (unsafeCoerce)

data Query a
    = ToggleState a
    | UserInput Event a

type Inflection nRows nCols cell =
    { rowLabels :: Vec nRows String
    , colLabels :: Vec nCols String
    , cells :: Vec nRows (Vec nCols cell)
    }

type Declension cell = Inflection D5 D2 cell
type Noun = Declension String

class Show d <= Display d where
    display :: forall a b. d -> HH.HTML a b

instance unitLabel :: Display Unit where
    display _ = HH.text ""

instance emptyLabel :: Display Void where
    display _ = HH.text ""

instance identityDisplay :: Display String where
    display = HH.text

newtype TableSection sectionT majRT minRT majCT minCT dataT =
    TableSection
        { section :: sectionT
        , rows :: Headers majRT minRT
        , cols :: Headers majCT minCT
        , getCell :: sectionT -> majRT -> minRT -> majCT -> minCT -> dataT
        }

instance showTableSection :: (
    Show sectionT, Show majRT, Show minRT, Show majCT, Show minCT, Show dataT
) => Show (TableSection sectionT majRT minRT majCT minCT dataT) where
    show (TableSection { section, rows, cols, getCell }) =
        unsafeStringify
            { section: show section
            , rows: map showHeader rows
            , cols: map showHeader cols
            }
        where
            showHeader :: forall a b. (Show a, Show b) => Header a b -> String
            showHeader { label, sub: [] } =
                show label
            showHeader { label, sub } =
                show label <> " " <> show sub

{-
instance showTableSection :: Show (TableSection Unit Degree minRT majCT minCT dataT) where
    show (TableSection { section, rows, cols, getCell }) =
        show $ map showHeader rows
        where
            showHeader { label } = show label
-}

newtype CompoundTable sectionT majRT minRT majCT minCT dataT
    = CompoundTable (Array (TableSection sectionT majRT minRT majCT minCT dataT))

instance showTable :: (
    Show sectionT, Show majRT, Show minRT, Show majCT, Show minCT, Show dataT
) => Show (CompoundTable sectionT majRT minRT majCT minCT dataT) where
    show (CompoundTable t) = show t

--instance showTable :: Show (CompoundTable Unit Degree minRT majCT minCT dataT) where show (CompoundTable t) = show t

simpleTable :: forall majRT minRT majCT minCT dataT.
    { rows :: Headers majRT minRT
    , cols :: Headers majCT minCT
    , getCell :: majRT -> minRT -> majCT -> minCT -> dataT
    } -> CompoundTable Unit majRT minRT majCT minCT dataT
simpleTable { rows, cols, getCell } =
    { section: unit
    , rows: rows
    , cols: cols
    , getCell: const getCell
    } # TableSection # Array.singleton # CompoundTable

simpleVertical :: forall majRT minRT majCT minCT dataT.
    { rows :: Array majRT
    , getCell :: majRT -> dataT
    } -> CompoundTable Unit majRT minRT majCT minCT dataT
simpleVertical { rows, getCell } =
    { section: unit
    , rows: fullRows
    , cols: []
    , getCell: \_ row _ _ _ -> getCell row
    } # TableSection # Array.singleton # CompoundTable
    where
        fullRows =
            map (\label -> { label, sub: [] }) rows

type Header majT minT =
    { label :: majT
    , sub :: Array minT
    }
type Headers majT minT = Array (Header majT minT)

computeGutterWidth :: forall sectionT majRT minRT majCT minCT dataT
     . CompoundTable sectionT majRT minRT majCT minCT dataT
    -> Int
computeGutterWidth (CompoundTable sections) =
    sections # map (\(TableSection { rows }) ->
        if Array.null rows then 0
        else if Array.all (_.sub >>> Array.null) rows
        then 1 else 2
    ) # maximum # fromMaybe 0

mcons :: forall a. Maybe a -> Array a -> Array a
mcons (Just head) tail = Array.cons head tail
mcons Nothing tail = tail

instance displayTable :: (
    Display sectionT, Display majRT, Display minRT, Display majCT, Display minCT, Display dataT
) => Display (CompoundTable sectionT majRT minRT majCT minCT dataT) where
    display ctable@(CompoundTable [TableSection section]) =
        HH.table_><HH.tbody_ $ map HH.tr_ rows
        where
            gutterWidth = computeGutterWidth ctable
            cell a
                | gutterWidth == 0 = Nothing
                | otherwise =
                    Just $ HH.th [ HP.colSpan gutterWidth ] a
            mkMajRowH contents
                | gutterWidth == 0 =
                    HH.th_ >< contents
                | otherwise =
                    HH.th [ HP.colSpan gutterWidth ] >< contents
            labelCellM = cell [ display section.section ]
            padCellM = cell $ []
            headerMajCols =
                section.cols # map (\{ label, sub } ->
                    HH.th [ HP.colSpan $ max 1 $ Array.length sub ] >< display label
                )
            header = mcons labelCellM headerMajCols
            subcol2s =
                section.cols # Array.concatMap (\{ label, sub } ->
                    map (Tuple label) sub
                )
            continue majRow minRow =
                subcol2s # map (\(Tuple majCol minCol) ->
                    HH.td_ >< display $ section.getCell section.section majRow minRow majCol minCol
                )
            subheaderM =
                if Array.any (\{ sub } -> not $ Array.null sub) section.cols
                then
                    section.cols # Array.concatMap (\{ sub } ->
                        case sub of
                            [] ->
                                [ HH.th_ [] ]
                            _ ->
                                map (\h -> HH.th_ >< display h) sub
                    ) # Just
                else Nothing
            headerrows =
                case subheaderM of
                    Nothing -> [ header ]
                    Just subheader ->
                        [ header, mcons padCellM subheader ]
            simplerows =
                Array.all (\{ sub } -> Array.null sub) section.cols
            contentrows =
                section.rows # Array.concatMap mkrow
            mkrow { label, sub } =
                if simplerows
                then
                    [ mcons padCellM [ HH.th_ [ display label ] ] ]
                else
                    let
                        subrows = map (\sublabel -> [ HH.th_ [], HH.th_ [ display sublabel ] ] <> continue label sublabel) sub
                    in [ [ mkMajRowH $ display label ] ] <> subrows
            rows = headerrows <> contentrows
    display _ = display "table"

{-
computeCellWidths :: forall majT minT. Header majT minT -> Header (majT, Int) (minT, Int)

let
    labelCell = case computeGutterWidth table of
        0 -> Nothing
        1 -> Just $ H.th_ $ display section.section
        width -> Just $ H.th [ HA.colspan width ] $ display section.section
    header =

in mcons labelCell header
-}

nomen :: Noun
nomen =
    { rowLabels: "nom" +> "gen" +> "dat" +> "acc" +> "abl" +> empty
    , colLabels: "sg" +> "pl" +> empty
    , cells:
        ( "nomen" +> "nomina" +> empty ) +>
        ( "nominis" +> "nominum" +> empty) +>
        ( "nomini" +> "nominibus" +> empty) +>
        ( "nomen" +> "nomina" +> empty) +>
        ( "nomine" +> "nominibus" +> empty) +>
        empty
    }

data Degree = Positive | Comparative | Superlative
instance showDegree :: Show Degree where
    show Positive = "positive"
    show Comparative = "comparative"
    show Superlative = "superlative"
instance displayDegree :: Display Degree where
    display = display <<< show

data Person = FirstP | SecondP | ThirdP
instance showPerson :: Show Person where
    show FirstP = "1st person"
    show SecondP = "2nd person"
    show ThirdP = "3rd person"
instance displayPerson :: Display Person where
    display = display <<< show

data Number2 = Singular | Plural
instance showNumber2 :: Show Number2 where
    show Singular = "singular"
    show Plural = "plural"
instance displayNumber2 :: Display Number2 where
    display = display <<< show

data Tense = Present | Imperfect | Future | Perfect | Pluperfect | FuturePerfect
instance showTense :: Show Tense where
    show Present = "present"
    show Imperfect = "imperfect"
    show Future = "future"
    show Perfect = "perfect"
    show Pluperfect = "pluperfect"
    show FuturePerfect = "future-perfect"
instance displayTense :: Display Tense where
    display = display <<< show

data Voice = Active | Passive
instance showVoice :: Show Voice where
    show Active = "active"
    show Passive = "passive"
instance displayVoice :: Display Voice where
    display = display <<< show

data Mood = Indicative | Subjunctive
instance showMood :: Show Mood where
    show Indicative = "indicative"
    show Subjunctive = "subjunctive"
instance displayMood :: Display Mood where
    display = display <<< show

celeriter :: CompoundTable Unit Degree Void Void Void String
celeriter = simpleVertical
    { rows: [Positive, Comparative, Superlative]
    , getCell: case _ of
        Positive -> "celeriter"
        Comparative -> "celerius"
        Superlative -> "celerrimē"
    }

headerproduct :: forall majT minT. Array majT -> Array minT -> Headers majT minT
headerproduct major minor =
    map (\label -> { label, sub: minor }) major

getCellVolo :: Mood -> Voice -> Tense -> Number2 -> Person -> String
getCellVolo Indicative Active Present Singular FirstP = "volo"
getCellVolo Indicative Active Present Singular SecondP = "vis"
getCellVolo Indicative Active Present Singular ThirdP = "volunt"
getCellVolo Indicative Active Present Plural FirstP = "volumus"
getCellVolo Indicative Active Present Plural SecondP = "vultis"
getCellVolo Indicative Active Present Plural ThirdP = "volunt"
getCellVolo _ _ _ _ _ = "UNK"

volo :: CompoundTable Mood Voice Tense Number2 Person String
volo = CompoundTable ([TableSection
    { section: Indicative
    , rows: headerproduct [Active] [Present]
    , cols: headerproduct [Singular, Plural] [FirstP, SecondP, ThirdP]
    , getCell: getCellVolo
    }])

type State =
    { on :: Boolean
    , text :: String
    }

initialState :: State
initialState =
    { on: false
    , text: "Hello"
    }

table :: forall cell nRows nCols a b. (Nat nRows, Nat nCols)
    => Inflection nRows nCols cell
    -> (cell -> HH.HTML a b)
    -> HH.HTML a b
table datable mapper = HH.table_><HH.tbody_ (map HH.tr_ (Array.cons header rows))
    where
      header = Array.cons (HH.th_/> "") $ map (HH.th[style (textAlign leftTextAlign)]/> _) $ toArray datable.colLabels
      labels = toArray datable.rowLabels
      label i = Maybe.fromMaybe "" $ Array.index labels i
      rows =
        Array.mapWithIndex rowOf $ toArray datable.cells
      rowOf i cells =
        Array.cons (HH.th_/> label i) (map mapper $ toArray cells)

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

  render :: State -> H.ComponentHTML Query
  render state =
    mdiv1 Layout.container
    ><mdiv [ MDL.layout ]
      [ mdiv1 Layout.content
        ><table nomen (input (HE.input UserInput) [] "Form of nomen" >>> (HH.td_><_))
      , mdiv1 Layout.content>< display volo
      ]

  eval :: Query ~> H.ComponentDSL State Query Void (Aff (dom :: DOM | eff))
  eval (ToggleState next) = do
    H.modify (\state -> { on: not state.on, text: "Bye" })
    pure next
  eval (UserInput e next) = do
    let node = unsafeCoerce Event.target e :: HTMLInputElement
    s <- H.liftEff (HInput.value node :: Eff (dom :: DOM | eff) String)
    H.modify (\state -> { on: state.on, text: s })
    pure next


Remove unused import

Remove unused import

The PureScript compiler warns about unused imports as of 0.7.6.

module Control.Monad.Eff.Exception.Unsafe where

import Prelude
import Control.Monad.Eff.Unsafe
import Control.Monad.Eff.Exception

-- | Throw an exception in pure code. This function should be used very
-- | sparingly, as it can cause unexpected crashes at runtime.
unsafeThrowException :: forall a. Error -> a
unsafeThrowException = unsafePerformEff <<< throwException

-- | Defined as `unsafeThrowException <<< error`.
unsafeThrow :: forall a. String -> a
unsafeThrow = unsafeThrowException <<< error

module Control.Monad.Eff.Exception.Unsafe where

import Prelude
import Control.Monad.Eff
import Control.Monad.Eff.Unsafe
import Control.Monad.Eff.Exception

-- | Throw an exception in pure code. This function should be used very
-- | sparingly, as it can cause unexpected crashes at runtime.
unsafeThrowException :: forall a. Error -> a
unsafeThrowException = unsafePerformEff <<< throwException

-- | Defined as `unsafeThrowException <<< error`.
unsafeThrow :: forall a. String -> a
unsafeThrow = unsafeThrowException <<< error