Don't generate duplicate unions

Don't generate duplicate unions

Original commit a5b44c29411a1c4607a01ab720df67b2adac6878

module CSharp
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude
import Types

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

data CSInfo = CSInfo { classNames ::  Map Int String, unionNames :: Map (Set IRType) String, unions :: List (Set IRType) }

type CSDoc = Doc CSInfo

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , extension: "cs"
    , render: renderGraphToCSharp
    }

renderGraphToCSharp :: IRGraph -> String
renderGraphToCSharp graph =
    let classes = classesInGraph graph
        classNames = transformNames nameForClass nextNameToTry (S.singleton "Converter") classes
        unions = L.nub $ filterTypes unionPredicate graph
        unionNames = transformNames (unionName classNames graph) nextNameToTry (S.fromFoldable $ M.values classNames) $ map (\s -> Tuple s s) unions
    in
        runDoc csharpDoc graph (CSInfo { classNames, unionNames, unions })
    where
        unionPredicate =
            case _ of
            IRUnion s ->
                if isNothing $ nullableFromSet s then
                    Just s
                else
                    Nothing
            _ -> Nothing
        nameForClass (IRClassData { names }) =
            csNameStyle $ combineNames names
        nextNameToTry s =
            "Other" <> s

unionName :: Map Int String -> IRGraph -> Set IRType -> String
unionName classNames graph s =
    "OneOf" <> (csNameStyle $ intercalate "_" $ map (typeNameForUnion classNames graph) $ L.sort $ L.fromFoldable s)

getClassNames :: CSDoc (Map Int String)
getClassNames = do
    CSInfo { classNames } <- getRendererInfo
    pure classNames

getUnions :: CSDoc (List (Set IRType))
getUnions = do
    CSInfo { unions } <- getRendererInfo
    pure unions

getUnionNames :: CSDoc (Map (Set IRType) String)
getUnionNames = do
    CSInfo { unionNames } <- getRendererInfo
    pure unionNames

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

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

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

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

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

stringify :: String -> String
stringify str =
    "\"" <> (Str.fromCharArray $ concatMap charRep $ Str.toCharArray str) <> "\""
    where
        charRep c =
            case c of
            '\\' -> ['\\', '\\']
            '\"' -> ['\\', '\"']
            '\n' -> ['\\', 'n']
            '\t' -> ['\\', 't']
            _ ->
                if isPrint c then
                    [c]
                else
                    let i = toCharCode c
                    in
                        if i <= 0xffff then
                            Str.toCharArray $ "\\u" <> intToHex 4 i
                        else
                            Str.toCharArray $ "\\U" <> intToHex 8 i

nullableFromSet :: Set IRType -> Maybe IRType
nullableFromSet s =
    case L.fromFoldable s of
    IRNull : x : L.Nil -> Just x
    x : IRNull : L.Nil -> Just x
    _ -> Nothing

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

lookupName :: forall a. Ord a => a -> Map a String -> String
lookupName original nameMap =
    fromMaybe "NAME_NOT_PROCESSED" $ M.lookup original nameMap

lookupClassName :: Int -> CSDoc String
lookupClassName i = do
    classNames <- getClassNames
    pure $ lookupName i classNames

lookupUnionName :: Set IRType -> CSDoc String
lookupUnionName s = do
    unionNames <- getUnionNames
    pure $ lookupName s unionNames

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

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

typeNameForUnion :: Map Int String -> IRGraph -> IRType -> String
typeNameForUnion classNames graph = case _ of
    IRNothing -> "nothing"
    IRNull -> "null"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> typeNameForUnion classNames graph a <> "_array"
    IRClass i ->
        let IRClassData { names } = getClassFromGraph graph i
        in
            combineNames names
    IRMap t -> typeNameForUnion classNames graph t <> "_map"
    IRUnion _ -> "union"

csharpDoc :: CSDoc Unit
csharpDoc = do
    lines """// To parse this JSON data, add NuGet 'Newtonsoft.Json' then do:
             //
             //   var data = QuickType.Converter.FromJson(jsonString);
             //
             namespace QuickType
             {"""
    blank
    indent do
        lines """using System;
                 using System.Net;
                 using System.Collections.Generic;

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

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

renderJsonConverter :: CSDoc Unit
renderJsonConverter = do
    unionNames <- getUnionNames
    let haveUnions = not $ M.isEmpty unionNames
    let names = M.values unionNames
    lines $ "class Converter" <> stringIfTrue haveUnions " : JsonConverter" <> " {"
    indent do
        IRGraph { toplevel } <- getGraph
        toplevelType <- renderTypeToCSharp toplevel
        lines "// Loading helpers"
        let converterParam = stringIfTrue haveUnions ", new Converter()"
        lines
            $ "public static "
            <> toplevelType
            <> " FromJson(string json) => JsonConvert.DeserializeObject<"
            <> toplevelType
            <> ">(json"
            <> converterParam
            <> ");"

        when haveUnions do
            blank
            lines "public override bool CanConvert(Type t) {"
            indent $ lines $ "return " <> intercalate " || " (map (\n -> "t == typeof(" <> n <> ")") names) <> ";"
            lines "}"
            blank
            lines "public override object ReadJson(JsonReader reader, Type t, object existingValue, JsonSerializer serializer) {"
            indent do
                -- FIXME: call the constructor via reflection?
                for_ names \name -> do
                    lines $ "if (t == typeof(" <> name <> "))"
                    indent $ lines $ "return new " <> name <> "(reader, serializer);"
                lines "throw new Exception(\"Unknown type\");"
            lines "}"
            blank
            lines "public override void WriteJson(JsonWriter writer, object value, JsonSerializer serializer) {"
            indent $ lines "throw new NotImplementedException();"
            lines "}"
            blank
            lines "public override bool CanWrite { get { return false; } }"
    lines "}"

tokenCase :: String -> CSDoc Unit
tokenCase tokenType =
    lines $ "case JsonToken." <> tokenType <> ":"

renderNullDeserializer :: Set IRType -> CSDoc Unit
renderNullDeserializer types =
    when (S.member IRNull types) do
        tokenCase "Null"
        indent do
            lines "break;"

unionFieldName :: IRType -> CSDoc String
unionFieldName t = do
    classNames <- getClassNames
    graph <- getGraph
    let typeName = typeNameForUnion classNames graph t
    pure $ csNameStyle typeName

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

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

renderPrimitiveDeserializer :: String -> IRType -> Set IRType -> CSDoc Unit
renderPrimitiveDeserializer tokenType t types =
    when (S.member t types) do
        tokenCase tokenType
        indent do
            deserializeType t

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

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

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

renderCSharpClass :: IRClassData -> String -> CSDoc Unit
renderCSharpClass (IRClassData { names, properties }) className = do
    let propertyNames = transformNames csNameStyle ("Other" <> _) (S.singleton className) $ map (\n -> Tuple n n) $ M.keys properties
    line $ words ["class", className]

    lines "{"
    indent do
        for_ (M.toUnfoldable properties :: Array _) \(Tuple pname ptype) -> do
            line do
                string "[JsonProperty("
                string $ stringify pname
                string ")]"
            line do
                string "public "
                rendered <- renderTypeToCSharp ptype
                string rendered
                let csPropName = lookupName pname propertyNames
                words ["", csPropName, "{ get; set; }"]
            blank
    lines "}"

module CSharp
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude
import Types

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

data CSInfo = CSInfo { classNames ::  Map Int String, unionNames :: Map (Set IRType) String, unions :: List (Set IRType) }

type CSDoc = Doc CSInfo

renderer :: Renderer
renderer =
    { name: "C#"
    , aceMode: "csharp"
    , extension: "cs"
    , render: renderGraphToCSharp
    }

renderGraphToCSharp :: IRGraph -> String
renderGraphToCSharp graph =
    let classes = classesInGraph graph
        classNames = transformNames nameForClass nextNameToTry (S.singleton "Converter") classes
        unions = filterTypes unionPredicate graph
        unionNames = transformNames (unionName classNames graph) nextNameToTry (S.fromFoldable $ M.values classNames) $ map (\s -> Tuple s s) unions
    in
        runDoc csharpDoc graph (CSInfo { classNames, unionNames, unions })
    where
        unionPredicate =
            case _ of
            IRUnion s ->
                if isNothing $ nullableFromSet s then
                    Just s
                else
                    Nothing
            _ -> Nothing
        nameForClass (IRClassData { names }) =
            csNameStyle $ combineNames names
        nextNameToTry s =
            "Other" <> s

unionName :: Map Int String -> IRGraph -> Set IRType -> String
unionName classNames graph s =
    "OneOf" <> (csNameStyle $ intercalate "_" $ map (typeNameForUnion classNames graph) $ L.sort $ L.fromFoldable s)

getClassNames :: CSDoc (Map Int String)
getClassNames = do
    CSInfo { classNames } <- getRendererInfo
    pure classNames

getUnions :: CSDoc (List (Set IRType))
getUnions = do
    CSInfo { unions } <- getRendererInfo
    pure unions

getUnionNames :: CSDoc (Map (Set IRType) String)
getUnionNames = do
    CSInfo { unionNames } <- getRendererInfo
    pure unionNames

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

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

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

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

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

stringify :: String -> String
stringify str =
    "\"" <> (Str.fromCharArray $ concatMap charRep $ Str.toCharArray str) <> "\""
    where
        charRep c =
            case c of
            '\\' -> ['\\', '\\']
            '\"' -> ['\\', '\"']
            '\n' -> ['\\', 'n']
            '\t' -> ['\\', 't']
            _ ->
                if isPrint c then
                    [c]
                else
                    let i = toCharCode c
                    in
                        if i <= 0xffff then
                            Str.toCharArray $ "\\u" <> intToHex 4 i
                        else
                            Str.toCharArray $ "\\U" <> intToHex 8 i

nullableFromSet :: Set IRType -> Maybe IRType
nullableFromSet s =
    case L.fromFoldable s of
    IRNull : x : L.Nil -> Just x
    x : IRNull : L.Nil -> Just x
    _ -> Nothing

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

lookupName :: forall a. Ord a => a -> Map a String -> String
lookupName original nameMap =
    fromMaybe "NAME_NOT_PROCESSED" $ M.lookup original nameMap

lookupClassName :: Int -> CSDoc String
lookupClassName i = do
    classNames <- getClassNames
    pure $ lookupName i classNames

lookupUnionName :: Set IRType -> CSDoc String
lookupUnionName s = do
    unionNames <- getUnionNames
    pure $ lookupName s unionNames

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

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

typeNameForUnion :: Map Int String -> IRGraph -> IRType -> String
typeNameForUnion classNames graph = case _ of
    IRNothing -> "nothing"
    IRNull -> "null"
    IRInteger -> "int"
    IRDouble -> "double"
    IRBool -> "bool"
    IRString -> "string"
    IRArray a -> typeNameForUnion classNames graph a <> "_array"
    IRClass i ->
        let IRClassData { names } = getClassFromGraph graph i
        in
            combineNames names
    IRMap t -> typeNameForUnion classNames graph t <> "_map"
    IRUnion _ -> "union"

csharpDoc :: CSDoc Unit
csharpDoc = do
    lines """// To parse this JSON data, add NuGet 'Newtonsoft.Json' then do:
             //
             //   var data = QuickType.Converter.FromJson(jsonString);
             //
             namespace QuickType
             {"""
    blank
    indent do
        lines """using System;
                 using System.Net;
                 using System.Collections.Generic;

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

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

renderJsonConverter :: CSDoc Unit
renderJsonConverter = do
    unionNames <- getUnionNames
    let haveUnions = not $ M.isEmpty unionNames
    let names = M.values unionNames
    lines $ "class Converter" <> stringIfTrue haveUnions " : JsonConverter" <> " {"
    indent do
        IRGraph { toplevel } <- getGraph
        toplevelType <- renderTypeToCSharp toplevel
        lines "// Loading helpers"
        let converterParam = stringIfTrue haveUnions ", new Converter()"
        lines
            $ "public static "
            <> toplevelType
            <> " FromJson(string json) => JsonConvert.DeserializeObject<"
            <> toplevelType
            <> ">(json"
            <> converterParam
            <> ");"

        when haveUnions do
            blank
            lines "public override bool CanConvert(Type t) {"
            indent $ lines $ "return " <> intercalate " || " (map (\n -> "t == typeof(" <> n <> ")") names) <> ";"
            lines "}"
            blank
            lines "public override object ReadJson(JsonReader reader, Type t, object existingValue, JsonSerializer serializer) {"
            indent do
                -- FIXME: call the constructor via reflection?
                for_ names \name -> do
                    lines $ "if (t == typeof(" <> name <> "))"
                    indent $ lines $ "return new " <> name <> "(reader, serializer);"
                lines "throw new Exception(\"Unknown type\");"
            lines "}"
            blank
            lines "public override void WriteJson(JsonWriter writer, object value, JsonSerializer serializer) {"
            indent $ lines "throw new NotImplementedException();"
            lines "}"
            blank
            lines "public override bool CanWrite { get { return false; } }"
    lines "}"

tokenCase :: String -> CSDoc Unit
tokenCase tokenType =
    lines $ "case JsonToken." <> tokenType <> ":"

renderNullDeserializer :: Set IRType -> CSDoc Unit
renderNullDeserializer types =
    when (S.member IRNull types) do
        tokenCase "Null"
        indent do
            lines "break;"

unionFieldName :: IRType -> CSDoc String
unionFieldName t = do
    classNames <- getClassNames
    graph <- getGraph
    let typeName = typeNameForUnion classNames graph t
    pure $ csNameStyle typeName

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

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

renderPrimitiveDeserializer :: String -> IRType -> Set IRType -> CSDoc Unit
renderPrimitiveDeserializer tokenType t types =
    when (S.member t types) do
        tokenCase tokenType
        indent do
            deserializeType t

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

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

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

renderCSharpClass :: IRClassData -> String -> CSDoc Unit
renderCSharpClass (IRClassData { names, properties }) className = do
    let propertyNames = transformNames csNameStyle ("Other" <> _) (S.singleton className) $ map (\n -> Tuple n n) $ M.keys properties
    line $ words ["class", className]

    lines "{"
    indent do
        for_ (M.toUnfoldable properties :: Array _) \(Tuple pname ptype) -> do
            line do
                string "[JsonProperty("
                string $ stringify pname
                string ")]"
            line do
                string "public "
                rendered <- renderTypeToCSharp ptype
                string rendered
                let csPropName = lookupName pname propertyNames
                words ["", csPropName, "{ get; set; }"]
            blank
    lines "}"


Use path separator from Node.Path

Use path separator from Node.Path

-----------------------------------------------------------------------------
--
-- Module      :  Language.PureScript
-- Copyright   :  (c) Phil Freeman 2013-14
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
-- The main compiler module
--
-----------------------------------------------------------------------------

module Language.PureScript (
    compile,
    compile',
    MonadMake,
    make,

    getTimestamp,
    readTextFile,
    writeTextFile,
    liftError,
    progress,

    procFilePath
  ) where

import Data.Array
import Data.Maybe
import Data.Tuple
import Data.Tuple3
import Data.Either
import Data.Function (on)
import Data.String (joinWith)
import Data.Foldable (all, any, elem, find, traverse_)
import Data.Traversable (for, traverse)

import qualified Data.Array.Unsafe as Unsafe
import qualified Data.Maybe.Unsafe as Unsafe

import qualified Data.Map as M
import qualified Data.Set as S

import Control.Monad
import Control.Monad.Trans
import Control.Monad.Error
import Control.Monad.Error.Class
import Control.Monad.State
import Control.Monad.State.Class

import Control.Apply

import Math (min)

import Language.PureScript.Types
import Language.PureScript.Kinds
import Language.PureScript.Declarations
import Language.PureScript.Names
import Language.PureScript.Options
import Language.PureScript.ModuleDependencies
import Language.PureScript.Environment
import Language.PureScript.Errors
{- import Language.PureScript.DeadCodeElimination -}
import Language.PureScript.Supply

import Language.PureScript.CodeGen.Common
import Language.PureScript.CodeGen.JS
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.CodeGen.Externs

import Language.PureScript.TypeChecker
import Language.PureScript.TypeChecker.Monad

import Language.PureScript.Sugar
import Language.PureScript.Sugar.BindingGroups

import Language.PureScript.Parser.Lexer (lex)
import Language.PureScript.Parser.Common
import Language.PureScript.Parser.Declarations (parseModule)

import Language.PureScript.Pretty.JS

import Node.Path

import qualified Language.PureScript.Constants as C

foreign import procFilePath "var procFilePath = require('fs').realpathSync(process.argv[1]);" :: String

-- |
-- Compile a collection of modules
--
-- The compilation pipeline proceeds as follows:
--
--  * Sort the modules based on module dependencies, checking for cyclic dependencies.
--
--  * Perform a set of desugaring passes.
--
--  * Type check, and elaborate values to include type annotations and type class dictionaries.
--
--  * Regroup values to take into account new value dependencies introduced by elaboration.
--
--  * Eliminate dead code.
--
--  * Generate Javascript, and perform optimization passes.
--
--  * Pretty-print the generated Javascript
--
compile :: Options -> [Module] -> Either String (Tuple3 String String Environment)
compile = compile' initEnvironment

compile' :: Environment -> Options -> [Module] -> Either String (Tuple3 String String Environment)
compile' env opts@(Options optso) ms = do
  Tuple sorted _ <- sortModules $ if optso.noPrelude then ms else (map importPrelude ms)
  Tuple desugared nextVar <- stringifyErrorStack true $ runSupplyT 0 $ desugar sorted
  Tuple elaborated env' <- runCheck' opts env $ for desugared $ typeCheckModule mainModuleIdent
  regrouped <- stringifyErrorStack true $ createBindingGroupsModule <<< collapseBindingGroupsModule $ elaborated
  let
    entryPoints = moduleNameFromString `map` optso.modules
    elim = regrouped -- if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped
    codeGenModules = moduleNameFromString `map` optso.codeGenModules
    modulesToCodeGen = if null codeGenModules then elim else filter (\(Module mn _ _) -> mn `elem` codeGenModules) elim
    js = evalSupply nextVar $ concat <$> traverse (\m -> moduleToJs Globals opts m env') modulesToCodeGen
    exts = joinWith "\n" <<< map (\m -> moduleToPs m env') $ modulesToCodeGen
  js' <- generateMain env' opts js
  return (Tuple3 (prettyPrintJS js') exts env')
  where
  mainModuleIdent = moduleNameFromString <$> optso.main

typeCheckModule :: Maybe ModuleName -> Module -> Check Module
typeCheckModule mainModuleName (Module mn decls exps) = do
  modify (\(CheckState st) -> CheckState (st { currentModule = Just mn }))
  decls' <- typeCheckAll mainModuleName mn decls
  traverse_ checkTypesAreExported exps'
  return $ Module mn decls' exps
  where

  exps' = Unsafe.fromJust exps

  -- Check that all the type constructors defined in the current module that appear in member types
  -- have also been exported from the module
  checkTypesAreExported :: DeclarationRef -> Check Unit
  checkTypesAreExported (ValueRef name) = do
    ty <- lookupVariable unifyError mn (Qualified (Just mn) name)
    case find isTconHidden (findTcons ty) of
      Just hiddenType -> throwError (strMsg ("Error in module '" ++ show mn ++
                                             "':\nExporting declaration '" ++ show name ++
                                             "' requires type '" ++ show hiddenType ++
                                             "' to be exported as well") :: ErrorStack)
      Nothing -> return unit
  checkTypesAreExported _ = return unit

  -- Find the type constructors exported from the current module used in a type
  findTcons :: Type -> [ProperName]
  findTcons = everythingOnTypes (++) go
    where
    go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [name]
    go _ = []

  -- Checks whether a type constructor is not being exported from the current module
  isTconHidden :: ProperName -> Boolean
  isTconHidden tyName = all go exps'
    where
    go (TypeRef tyName' _) = tyName' /= tyName
    go _ = true

generateMain :: Environment -> Options -> [JS] -> Either String [JS]
generateMain env@(Environment envo) opts@(Options optso) js =
  case moduleNameFromString <$> optso.main of
    Just mmi -> do
      unless (Tuple mmi (Ident C.main) `M.member` envo.names) $
        Left $ show mmi ++ "." ++ C.main ++ " is undefined"
      return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (Unsafe.fromJust optso.browserNamespace)))) []]
    _ -> return js

-- |
-- A type class which collects the IO actions we need to be able to run in "make" mode
--
class (Monad m) <= MonadMake m where
  -- |
  -- Get a file timestamp
  --
  getTimestamp :: FilePath -> m (Maybe Number)

  -- |
  -- Read a file as a string
  --
  readTextFile :: FilePath -> m String

  -- |
  -- Write a text file
  --
  writeTextFile :: FilePath -> String -> m Unit

  -- |
  -- Report an error
  --
  liftError :: forall a. Either String a -> m a

  -- |
  -- Respond to a progress update
  --
  progress :: String -> m Unit

-- |
-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
--
-- If timestamps have not changed, the externs file can be used to provide the module's types without
-- having to typecheck the module again.
--
make :: forall m. (Functor m, Apply m, Applicative m, Bind m, Monad m, MonadMake m) => RequirePathType -> FilePath -> Options -> [Tuple FilePath Module] -> m Environment
make rpt outputDir opts@(Options optso) ms = do
  let filePathMap = M.fromList (map (\(Tuple fp (Module mn _ _)) -> Tuple mn fp) ms)

  Tuple sorted graph <- liftError $ sortModules $ if optso.noPrelude then map snd ms else (map (importPrelude <<< snd) ms)

  toRebuild <- foldM (\s (Module moduleName' _ _) ->
    do let filePath = runModuleName moduleName'

           jsFile      = outputDir ++ sep ++ filePath ++ sep ++ "index.js"
           externsFile = outputDir ++ sep ++ filePath ++ sep ++ "externs.purs"
           inputFile   = fromMaybe (error "Input file is undefined in make") $ M.lookup moduleName' filePathMap

       jsTimestamp      <- getTimestamp jsFile
       externsTimestamp <- getTimestamp externsFile
       inputTimestamp   <- getTimestamp inputFile

       return $ case (Tuple3 inputTimestamp jsTimestamp externsTimestamp) of
         Tuple3 (Just t1) (Just t2) (Just t3) | t1 < min t2 t3 -> s
         _ -> S.insert moduleName' s
    ) S.empty sorted

  marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted

  Tuple desugared nextVar <- liftError $ stringifyErrorStack true $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)

  evalSupplyT nextVar (go initEnvironment desugared)

  where
  go :: forall m. (Functor m, Apply m, Applicative m, Bind m, Monad m, MonadMake m) => Environment -> [Tuple Boolean Module] -> SupplyT m Environment
  go env [] = return env
  go env (Tuple false m : ms') = do
    Tuple _ env' <- lift (liftError (runCheck' opts env (typeCheckModule Nothing m)))
    go env' ms'
  go env (Tuple true (m@(Module moduleName' _ exps)) : ms') = do
    let filePath = runModuleName moduleName'
        jsFile = outputDir ++ sep ++ filePath ++ sep ++ "index.js"
        externsFile = outputDir ++ sep ++ filePath ++ sep ++ "externs.purs"

    lift (progress ("Compiling " ++ runModuleName moduleName'))

    Tuple (Module _ elaborated _) env' <- lift (liftError (runCheck' opts env (typeCheckModule Nothing m)))

    regrouped <- lift (liftError (stringifyErrorStack true (createBindingGroups moduleName' (collapseBindingGroups elaborated))))

    let mod' = Module moduleName' regrouped exps
    js <- prettyPrintJS <$> moduleToJs (CommonJS rpt) opts mod' env'
    let exts = moduleToPs mod' env'

    lift $ writeTextFile jsFile js
    lift $ writeTextFile externsFile exts

    go env' ms'

  rebuildIfNecessary :: forall m. (Functor m, Apply m, Applicative m, Bind m, Monad m, MonadMake m) => M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [Tuple Boolean Module]
  rebuildIfNecessary _ _ [] = return []
  rebuildIfNecessary graph toRebuild ((m@(Module moduleName' _ _)) : ms') | moduleName' `S.member` toRebuild = do
    let deps = fromMaybe [] $ moduleName' `M.lookup` graph
        toRebuild' = toRebuild `S.union` S.fromList deps
    (:) (Tuple true m) <$> rebuildIfNecessary graph toRebuild' ms'
  rebuildIfNecessary graph toRebuild (Module moduleName' _ _ : ms') = do
    let externsFile = outputDir ++ sep ++ runModuleName moduleName' ++ sep ++ "externs.purs"
    externs <- readTextFile externsFile
    externsModule <- liftError (either (Left <<< show) Right (lex externs >>= runTokenParser parseModule))
    case externsModule of
      m'@(Module moduleName'' _ _) | moduleName'' == moduleName' -> (:) (Tuple false m') <$> rebuildIfNecessary graph toRebuild ms'
      _ -> liftError (Left ("Externs file " ++ externsFile ++ " was invalid"))

reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
reverseDependencies g = combine $ do Tuple mn deps <- g
                                     dep <- deps
                                     return (Tuple dep mn)
  where
  combine :: forall a b. (Ord a) => [Tuple a b] -> M.Map a [b]
  combine = M.fromList <<< map (\xs -> Tuple (fst (Unsafe.head xs)) (map snd xs)) <<< groupBy ((==) `on` fst) <<< sortBy (compare `on` fst)

-- |
-- Add an import declaration for the Prelude to a module if it does not already explicitly import
-- it.
--
importPrelude :: Module -> Module
importPrelude m@(Module mn decls exps) =
  if any isPreludeImport decls || mn == prelude then m else Module mn (preludeImport : decls) exps
  where
  prelude :: ModuleName
  prelude = ModuleName [ProperName C.prelude]

  isPreludeImport :: Declaration -> Boolean
  isPreludeImport (ImportDeclaration (ModuleName [ProperName mn']) _ _) | mn' == C.prelude = true
  isPreludeImport (PositionedDeclaration _ d) = isPreludeImport d
  isPreludeImport _ = false

  preludeImport :: Declaration
  preludeImport = ImportDeclaration prelude Nothing Nothing

-----------------------------------------------------------------------------
--
-- Module      :  Language.PureScript
-- Copyright   :  (c) Phil Freeman 2013-14
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
-- The main compiler module
--
-----------------------------------------------------------------------------

module Language.PureScript (
    compile,
    compile',
    MonadMake,
    make,

    getTimestamp,
    readTextFile,
    writeTextFile,
    liftError,
    progress,

    procFilePath
  ) where

import Data.Array
import Data.Maybe
import Data.Tuple
import Data.Tuple3
import Data.Either
import Data.Function (on)
import Data.String (joinWith)
import Data.Foldable (all, any, elem, find, traverse_)
import Data.Traversable (for, traverse)

import qualified Data.Array.Unsafe as Unsafe
import qualified Data.Maybe.Unsafe as Unsafe

import qualified Data.Map as M
import qualified Data.Set as S

import Control.Monad
import Control.Monad.Trans
import Control.Monad.Error
import Control.Monad.Error.Class
import Control.Monad.State
import Control.Monad.State.Class

import Control.Apply

import Math (min)

import Language.PureScript.Types
import Language.PureScript.Kinds
import Language.PureScript.Declarations
import Language.PureScript.Names
import Language.PureScript.Options
import Language.PureScript.ModuleDependencies
import Language.PureScript.Environment
import Language.PureScript.Errors
{- import Language.PureScript.DeadCodeElimination -}
import Language.PureScript.Supply

import Language.PureScript.CodeGen.Common
import Language.PureScript.CodeGen.JS
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.CodeGen.Externs

import Language.PureScript.TypeChecker
import Language.PureScript.TypeChecker.Monad

import Language.PureScript.Sugar
import Language.PureScript.Sugar.BindingGroups

import Language.PureScript.Parser.Lexer (lex)
import Language.PureScript.Parser.Common
import Language.PureScript.Parser.Declarations (parseModule)

import Language.PureScript.Pretty.JS

import Node.Path

import qualified Language.PureScript.Constants as C

foreign import pathSeparator "var pathSeparator = require('path').sep" :: String

foreign import procFilePath "var procFilePath = require('fs').realpathSync(process.argv[1]);" :: String

-- |
-- Compile a collection of modules
--
-- The compilation pipeline proceeds as follows:
--
--  * Sort the modules based on module dependencies, checking for cyclic dependencies.
--
--  * Perform a set of desugaring passes.
--
--  * Type check, and elaborate values to include type annotations and type class dictionaries.
--
--  * Regroup values to take into account new value dependencies introduced by elaboration.
--
--  * Eliminate dead code.
--
--  * Generate Javascript, and perform optimization passes.
--
--  * Pretty-print the generated Javascript
--
compile :: Options -> [Module] -> Either String (Tuple3 String String Environment)
compile = compile' initEnvironment

compile' :: Environment -> Options -> [Module] -> Either String (Tuple3 String String Environment)
compile' env opts@(Options optso) ms = do
  Tuple sorted _ <- sortModules $ if optso.noPrelude then ms else (map importPrelude ms)
  Tuple desugared nextVar <- stringifyErrorStack true $ runSupplyT 0 $ desugar sorted
  Tuple elaborated env' <- runCheck' opts env $ for desugared $ typeCheckModule mainModuleIdent
  regrouped <- stringifyErrorStack true $ createBindingGroupsModule <<< collapseBindingGroupsModule $ elaborated
  let
    entryPoints = moduleNameFromString `map` optso.modules
    elim = regrouped -- if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped
    codeGenModules = moduleNameFromString `map` optso.codeGenModules
    modulesToCodeGen = if null codeGenModules then elim else filter (\(Module mn _ _) -> mn `elem` codeGenModules) elim
    js = evalSupply nextVar $ concat <$> traverse (\m -> moduleToJs Globals opts m env') modulesToCodeGen
    exts = joinWith "\n" <<< map (\m -> moduleToPs m env') $ modulesToCodeGen
  js' <- generateMain env' opts js
  return (Tuple3 (prettyPrintJS js') exts env')
  where
  mainModuleIdent = moduleNameFromString <$> optso.main

typeCheckModule :: Maybe ModuleName -> Module -> Check Module
typeCheckModule mainModuleName (Module mn decls exps) = do
  modify (\(CheckState st) -> CheckState (st { currentModule = Just mn }))
  decls' <- typeCheckAll mainModuleName mn decls
  traverse_ checkTypesAreExported exps'
  return $ Module mn decls' exps
  where

  exps' = Unsafe.fromJust exps

  -- Check that all the type constructors defined in the current module that appear in member types
  -- have also been exported from the module
  checkTypesAreExported :: DeclarationRef -> Check Unit
  checkTypesAreExported (ValueRef name) = do
    ty <- lookupVariable unifyError mn (Qualified (Just mn) name)
    case find isTconHidden (findTcons ty) of
      Just hiddenType -> throwError (strMsg ("Error in module '" ++ show mn ++
                                             "':\nExporting declaration '" ++ show name ++
                                             "' requires type '" ++ show hiddenType ++
                                             "' to be exported as well") :: ErrorStack)
      Nothing -> return unit
  checkTypesAreExported _ = return unit

  -- Find the type constructors exported from the current module used in a type
  findTcons :: Type -> [ProperName]
  findTcons = everythingOnTypes (++) go
    where
    go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [name]
    go _ = []

  -- Checks whether a type constructor is not being exported from the current module
  isTconHidden :: ProperName -> Boolean
  isTconHidden tyName = all go exps'
    where
    go (TypeRef tyName' _) = tyName' /= tyName
    go _ = true

generateMain :: Environment -> Options -> [JS] -> Either String [JS]
generateMain env@(Environment envo) opts@(Options optso) js =
  case moduleNameFromString <$> optso.main of
    Just mmi -> do
      unless (Tuple mmi (Ident C.main) `M.member` envo.names) $
        Left $ show mmi ++ "." ++ C.main ++ " is undefined"
      return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (Unsafe.fromJust optso.browserNamespace)))) []]
    _ -> return js

-- |
-- A type class which collects the IO actions we need to be able to run in "make" mode
--
class (Monad m) <= MonadMake m where
  -- |
  -- Get a file timestamp
  --
  getTimestamp :: FilePath -> m (Maybe Number)

  -- |
  -- Read a file as a string
  --
  readTextFile :: FilePath -> m String

  -- |
  -- Write a text file
  --
  writeTextFile :: FilePath -> String -> m Unit

  -- |
  -- Report an error
  --
  liftError :: forall a. Either String a -> m a

  -- |
  -- Respond to a progress update
  --
  progress :: String -> m Unit

-- |
-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
--
-- If timestamps have not changed, the externs file can be used to provide the module's types without
-- having to typecheck the module again.
--
make :: forall m. (Functor m, Apply m, Applicative m, Bind m, Monad m, MonadMake m) => RequirePathType -> FilePath -> Options -> [Tuple FilePath Module] -> m Environment
make rpt outputDir opts@(Options optso) ms = do
  let filePathMap = M.fromList (map (\(Tuple fp (Module mn _ _)) -> Tuple mn fp) ms)

  Tuple sorted graph <- liftError $ sortModules $ if optso.noPrelude then map snd ms else (map (importPrelude <<< snd) ms)

  toRebuild <- foldM (\s (Module moduleName' _ _) ->
    do let filePath = runModuleName moduleName'

           jsFile      = outputDir ++ pathSeparator ++ filePath ++ pathSeparator ++ "index.js"
           externsFile = outputDir ++ pathSeparator ++ filePath ++ pathSeparator ++ "externs.purs"
           inputFile   = fromMaybe (error "Input file is undefined in make") $ M.lookup moduleName' filePathMap

       jsTimestamp      <- getTimestamp jsFile
       externsTimestamp <- getTimestamp externsFile
       inputTimestamp   <- getTimestamp inputFile

       return $ case (Tuple3 inputTimestamp jsTimestamp externsTimestamp) of
         Tuple3 (Just t1) (Just t2) (Just t3) | t1 < min t2 t3 -> s
         _ -> S.insert moduleName' s
    ) S.empty sorted

  marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted

  Tuple desugared nextVar <- liftError $ stringifyErrorStack true $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)

  evalSupplyT nextVar (go initEnvironment desugared)

  where
  go :: forall m. (Functor m, Apply m, Applicative m, Bind m, Monad m, MonadMake m) => Environment -> [Tuple Boolean Module] -> SupplyT m Environment
  go env [] = return env
  go env (Tuple false m : ms') = do
    Tuple _ env' <- lift (liftError (runCheck' opts env (typeCheckModule Nothing m)))
    go env' ms'
  go env (Tuple true (m@(Module moduleName' _ exps)) : ms') = do
    let filePath = runModuleName moduleName'
        jsFile = outputDir ++ pathSeparator ++ filePath ++ pathSeparator ++ "index.js"
        externsFile = outputDir ++ pathSeparator ++ filePath ++ pathSeparator ++ "externs.purs"

    lift (progress ("Compiling " ++ runModuleName moduleName'))

    Tuple (Module _ elaborated _) env' <- lift (liftError (runCheck' opts env (typeCheckModule Nothing m)))

    regrouped <- lift (liftError (stringifyErrorStack true (createBindingGroups moduleName' (collapseBindingGroups elaborated))))

    let mod' = Module moduleName' regrouped exps
    js <- prettyPrintJS <$> moduleToJs (CommonJS rpt) opts mod' env'
    let exts = moduleToPs mod' env'

    lift $ writeTextFile jsFile js
    lift $ writeTextFile externsFile exts

    go env' ms'

  rebuildIfNecessary :: forall m. (Functor m, Apply m, Applicative m, Bind m, Monad m, MonadMake m) => M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [Tuple Boolean Module]
  rebuildIfNecessary _ _ [] = return []
  rebuildIfNecessary graph toRebuild ((m@(Module moduleName' _ _)) : ms') | moduleName' `S.member` toRebuild = do
    let deps = fromMaybe [] $ moduleName' `M.lookup` graph
        toRebuild' = toRebuild `S.union` S.fromList deps
    (:) (Tuple true m) <$> rebuildIfNecessary graph toRebuild' ms'
  rebuildIfNecessary graph toRebuild (Module moduleName' _ _ : ms') = do
    let externsFile = outputDir ++ pathSeparator ++ runModuleName moduleName' ++ pathSeparator ++ "externs.purs"
    externs <- readTextFile externsFile
    externsModule <- liftError (either (Left <<< show) Right (lex externs >>= runTokenParser parseModule))
    case externsModule of
      m'@(Module moduleName'' _ _) | moduleName'' == moduleName' -> (:) (Tuple false m') <$> rebuildIfNecessary graph toRebuild ms'
      _ -> liftError (Left ("Externs file " ++ externsFile ++ " was invalid"))

reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
reverseDependencies g = combine $ do Tuple mn deps <- g
                                     dep <- deps
                                     return (Tuple dep mn)
  where
  combine :: forall a b. (Ord a) => [Tuple a b] -> M.Map a [b]
  combine = M.fromList <<< map (\xs -> Tuple (fst (Unsafe.head xs)) (map snd xs)) <<< groupBy ((==) `on` fst) <<< sortBy (compare `on` fst)

-- |
-- Add an import declaration for the Prelude to a module if it does not already explicitly import
-- it.
--
importPrelude :: Module -> Module
importPrelude m@(Module mn decls exps) =
  if any isPreludeImport decls || mn == prelude then m else Module mn (preludeImport : decls) exps
  where
  prelude :: ModuleName
  prelude = ModuleName [ProperName C.prelude]

  isPreludeImport :: Declaration -> Boolean
  isPreludeImport (ImportDeclaration (ModuleName [ProperName mn']) _ _) | mn' == C.prelude = true
  isPreludeImport (PositionedDeclaration _ d) = isPreludeImport d
  isPreludeImport _ = false

  preludeImport :: Declaration
  preludeImport = ImportDeclaration prelude Nothing Nothing


Fix AST tests

Fix AST tests

module Test.AST where

import Prelude
import Data.List (List, singleton)
import Data.Array as Array
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))

import Control.Monad.Writer (Writer, tell)

import AST (Tree(..), Atom(..), Binding(..), Op(..), QualTree(..), Expr)

toList :: forall a. Array a -> List a
toList = Array.toUnfoldable

tell' :: forall a. a -> Writer (List a) Unit
tell' = tell <<< singleton

test :: forall a. (Show a, Eq a) => String -> a -> a -> Writer (List String) Unit
test name input expected = case input == expected of
  false -> tell' $ "AST fail (" <> name <> "): " <> show input <> " should be " <> show expected
  true  -> pure unit

runTests :: Writer (List String) Unit
runTests = do
--   test "idFoldTree_atom" (idFoldTree atom) atom
--   test "idFoldTree_list" (idFoldTree list) list
--   test "idFoldTree_ntuple" (idFoldTree ntuple) ntuple
--   test "idFoldTree_binary" (idFoldTree binary) binary
--   test "idFoldTree_unary" (idFoldTree unary) unary
--   test "idFoldTree_sectl" (idFoldTree sectl) sectl
--   test "idFoldTree_sectr" (idFoldTree sectr) sectr
--   test "idFoldTree_prefixop" (idFoldTree prefixop) prefixop
--   test "idFoldTree_ifexpr" (idFoldTree ifexpr) ifexpr
--   test "idFoldTree_arithmseq" (idFoldTree arithmseq) arithmseq
--   test "idFoldTree_letexpr" (idFoldTree letexpr) letexpr
--   test "idFoldTree_lambda" (idFoldTree lambda) lambda
--   test "idFoldTree_app" (idFoldTree app) app
--   test "idFoldTree_listcomp" (idFoldTree listcomp) listcomp

  test "map_atom" (map id atom) atom
  test "map_list" (map id list) list
  test "map_ntuple" (map id ntuple) ntuple
  test "map_binary" (map id binary) binary
  test "map_unary" (map id unary) unary
  test "map_sectl" (map id sectl) sectl
  test "map_sectr" (map id sectr) sectr
  test "map_prefixop" (map id prefixop) prefixop
  test "map_ifexpr" (map id ifexpr) ifexpr
  test "map_arithmseq" (map id arithmseq) arithmseq
  test "map_letexpr" (map id letexpr) letexpr
  test "map_lambda" (map id lambda) lambda
  test "map_app" (map id app) app
  test "map_listcomp" (map id listcomp) listcomp

atom :: Expr
atom = Atom unit (Name "x")

list :: Expr
list = List unit $ toList [atom, atom]

ntuple :: Expr
ntuple = NTuple unit $ toList [atom, atom]

binary :: Expr
binary = Binary unit Add atom atom

unary :: Expr
unary = Unary unit Sub atom

sectl :: Expr
sectl = SectL unit atom Add

sectr :: Expr
sectr = SectR unit Add atom

prefixop :: Expr
prefixop = PrefixOp unit Add

ifexpr :: Expr
ifexpr = IfExpr unit atom atom atom

arithmseq :: Expr
arithmseq = ArithmSeq unit atom (Just atom) (Just atom)

binding :: Binding Unit
binding = Lit unit (Name "x")

letexpr :: Expr
letexpr = LetExpr unit (toList [Tuple binding atom]) atom

lambda :: Expr
lambda = Lambda unit (toList [binding]) atom

app :: Expr
app = App unit atom (toList [atom, atom])

listcomp :: Expr
listcomp = ListComp unit atom (toList [Gen unit binding atom, Let unit binding atom, Guard unit atom])

module Test.AST where

import Prelude
import Data.List (List, singleton)
import Data.Array as Array
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))

import Control.Monad.Writer (Writer, tell)

import AST (Tree(..), Atom(..), Binding(..), Op(..), QualTree(..), idFoldTree, Expr)

toList :: forall a. Array a -> List a
toList = Array.toUnfoldable

tell' :: forall a. a -> Writer (List a) Unit
tell' = tell <<< singleton

test :: forall a. (Show a, Eq a) => String -> a -> a -> Writer (List String) Unit
test name input expected = case input == expected of
  false -> tell' $ "AST fail (" <> name <> "): " <> show input <> " should be " <> show expected
  true  -> pure unit

runTests :: Writer (List String) Unit
runTests = do
  test "idFoldTree_atom" (idFoldTree atom) atom
  test "idFoldTree_list" (idFoldTree list) list
  test "idFoldTree_ntuple" (idFoldTree ntuple) ntuple
  test "idFoldTree_binary" (idFoldTree binary) binary
  test "idFoldTree_unary" (idFoldTree unary) unary
  test "idFoldTree_sectl" (idFoldTree sectl) sectl
  test "idFoldTree_sectr" (idFoldTree sectr) sectr
  test "idFoldTree_prefixop" (idFoldTree prefixop) prefixop
  test "idFoldTree_ifexpr" (idFoldTree ifexpr) ifexpr
  test "idFoldTree_arithmseq" (idFoldTree arithmseq) arithmseq
  test "idFoldTree_letexpr" (idFoldTree letexpr) letexpr
  test "idFoldTree_lambda" (idFoldTree lambda) lambda
  test "idFoldTree_app" (idFoldTree app) app
  test "idFoldTree_listcomp" (idFoldTree listcomp) listcomp

  test "map_atom" (map id atom) atom
  test "map_list" (map id list) list
  test "map_ntuple" (map id ntuple) ntuple
  test "map_binary" (map id binary) binary
  test "map_unary" (map id unary) unary
  test "map_sectl" (map id sectl) sectl
  test "map_sectr" (map id sectr) sectr
  test "map_prefixop" (map id prefixop) prefixop
  test "map_ifexpr" (map id ifexpr) ifexpr
  test "map_arithmseq" (map id arithmseq) arithmseq
  test "map_letexpr" (map id letexpr) letexpr
  test "map_lambda" (map id lambda) lambda
  test "map_app" (map id app) app
  test "map_listcomp" (map id listcomp) listcomp

atom :: Expr
atom = Atom unit (Name "x")

list :: Expr
list = List unit $ toList [atom, atom]

ntuple :: Expr
ntuple = NTuple unit $ toList [atom, atom]

binary :: Expr
binary = Binary unit Add atom atom

unary :: Expr
unary = Unary unit Sub atom

sectl :: Expr
sectl = SectL unit atom Add

sectr :: Expr
sectr = SectR unit Add atom

prefixop :: Expr
prefixop = PrefixOp unit Add

ifexpr :: Expr
ifexpr = IfExpr unit atom atom atom

arithmseq :: Expr
arithmseq = ArithmSeq unit atom (Just atom) (Just atom)

binding :: Binding Unit
binding = Lit unit (Name "x")

letexpr :: Expr
letexpr = LetExpr unit (toList [Tuple binding atom]) atom

lambda :: Expr
lambda = Lambda unit (toList [binding]) atom

app :: Expr
app = App unit atom (toList [atom, atom])

listcomp :: Expr
listcomp = ListComp unit atom (toList [Gen unit binding atom, Let unit binding atom, Guard unit atom])


turnDelay respects fastTurn=true

turnDelay respects fastTurn=true

module App.Config where

import Prelude (($))
import Data.Maybe (Maybe(..))
import App.BoardView (class BoardView, getTurn)
import App.Turn (Turn(..))

type Config =
  { fastTurn :: Boolean
  }

turnDelay :: forall state action. BoardView state action
          => Config -> state -> Int
turnDelay config state =
  if config.fastTurn
    then 0
    else go $ getTurn state
    where go (Just Capture) = 500
          go (Just Lift) = 500
          go (Just Sow) = 50
          go _ = 100

module App.Config where

import Prelude (($))
import Data.Maybe (Maybe(..))
import App.BoardView (class BoardView, getTurn)
import App.Turn (Turn(..))

type Config =
  { fastTurn :: Boolean
  }

turnDelay :: forall state action. BoardView state action
          => Config -> state -> Int
turnDelay config state =
  go $ getTurn state
    where go (Just Capture) = 500
          go (Just Lift) = 500
          go (Just Sow) = 50
          go _ = 100


use triple-quoted strings to avoid backslashes

module Global
  ( nan
  , isNaN
  , infinity
  , isFinite
  , readInt
  , readFloat
  ) where

foreign import nan "var nan = NaN;" :: Number

foreign import isNaN :: Number -> Boolean

foreign import infinity "var infinity = Infinity;" :: Number

foreign import isFinite :: Number -> Boolean

foreign import readInt
  """
  function readInt(radix) {
    return function(n) {
      return parseInt(n, radix);
    };
  }
  """ :: Number -> String -> Number

foreign import readFloat "var readFloat = parseFloat;" :: String -> Number

module Global
  ( nan
  , isNaN
  , infinity
  , isFinite
  , readInt
  , readFloat
  ) where

foreign import nan "var nan = NaN;" :: Number

foreign import isNaN :: Number -> Boolean

foreign import infinity "var infinity = Infinity;" :: Number

foreign import isFinite :: Number -> Boolean

foreign import readInt
  "function readInt(radix) {\
  \  return function(n) {\
  \    return parseInt(n, radix);\
  \  };\
  \}" :: Number -> String -> Number

foreign import readFloat "var readFloat = parseFloat;" :: String -> Number


port for all the commands

port for all the commands

module PscIde where

import PscIde.Command
import Control.Alt ((<|>))
import Control.Bind (join)
import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (Error)
import Data.Argonaut (class DecodeJson, class EncodeJson, encodeJson)
import Data.Either (Either)
import Data.Maybe (Maybe(..))
import Prelude (Unit, pure, (<$>), (>>>), show)

foreign import data NET :: !

foreign import send :: forall eff.
  String -> -- ^ Command
  Int ->  -- ^ Port
  (String -> Eff (net :: NET | eff) Unit) -> -- ^ Callback
  (Error -> Eff (net :: NET | eff) Unit) -> -- ^ Error Callback
  Eff (net :: NET | eff) Unit

type Cmd a = forall eff. Aff (net :: NET | eff) (Result a)
type CmdR a b = forall eff. Aff (net :: NET | eff) (Result (Either a b))

sendCommandG :: forall i oe o. (EncodeJson i, DecodeJson oe, DecodeJson o) =>
                Int -> i -> (String -> Result (Either oe o)) -> CmdR oe o
sendCommandG port command unwrapper =
  makeAff (\err succ ->
            send (show (encodeJson command)) port (unwrapper >>> succ) err)

sendCommandR :: forall i oe o. (EncodeJson i, DecodeJson oe, DecodeJson o) => Int -> i -> CmdR oe o
sendCommandR port command = sendCommandG port command unwrapResponse

sendCommand :: forall i o. (EncodeJson i, DecodeJson o) => Int -> i -> Cmd o
sendCommand port command =
  makeAff (\err succ ->
            send (show (encodeJson command)) port (unwrapResponse >>> join >>> succ) err)

cwd :: Int -> Cmd Message
cwd port = sendCommand port Cwd

listLoadedModules :: Int -> Cmd ModuleList
listLoadedModules port = sendCommand port (Ls LoadedModules)

listAvailableModules :: Int -> Cmd ModuleList
listAvailableModules port = sendCommand port (Ls AvailableModules)

listImports :: Int -> String -> Cmd ImportList
listImports port fp = sendCommand port (Ls (Imports fp))

load ::
  Int ->
  Array String ->
  Array String ->
  Cmd Message
load port ms ds = sendCommand port (Load ms ds)

quit :: Int -> Cmd Message
quit port = sendCommand port Quit

pursuitCompletion :: Int -> String -> Cmd (Array PursuitCompletion)
pursuitCompletion port q = sendCommand port (Pursuit Ident q)

complete ::
  Int ->
  Array Filter ->
  Maybe Matcher ->
  Cmd (Array Completion)
complete port fs m = sendCommand port (Complete fs m)

type' ::
  Int ->
  String ->
  Array Filter ->
  Cmd (Array Completion)
type' port s fs = sendCommand port (Type s fs)

suggestTypos ::
  Int ->
  String ->
  Int ->
  Cmd (Array Completion)
suggestTypos port q m = (_ <|> pure []) <$> complete port [] (Just (Distance q m))

addClause :: Int -> String -> Boolean -> Cmd (Array String)
addClause port line annotations = sendCommand port (AddClause line annotations)

caseSplit :: Int -> String -> Int -> Int -> Boolean -> String -> Cmd (Array String)
caseSplit port line begin end annotations typ =
  sendCommand port (CaseSplit line begin end annotations typ)

implicitImport :: Int -> String -> (Maybe String) -> (Array Filter) -> String -> Cmd (ImportResult)
implicitImport port infile outfile filters mod = sendCommand port (ImportCmd infile outfile filters (AddImplicitImport mod))

explicitImport :: Int -> String -> (Maybe String) -> (Array Filter) -> String -> Cmd (ImportResult)
explicitImport port infile outfile filters ident = sendCommand port (ImportCmd infile outfile filters (AddImport ident))

rebuild :: Int -> String -> CmdR RebuildResult RebuildResult
rebuild port file = sendCommandR port (RebuildCmd file)

module PscIde where

import PscIde.Command
import Control.Alt ((<|>))
import Control.Bind (join)
import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (Error)
import Data.Argonaut (class DecodeJson, class EncodeJson, encodeJson)
import Data.Either (Either)
import Data.Maybe (Maybe(..))
import Prelude (Unit, pure, (<$>), (>>>), show)

foreign import data NET :: !

foreign import send :: forall eff.
  String -> -- ^ Command
  Int ->  -- ^ Port
  (String -> Eff (net :: NET | eff) Unit) -> -- ^ Callback
  (Error -> Eff (net :: NET | eff) Unit) -> -- ^ Error Callback
  Eff (net :: NET | eff) Unit

type Cmd a = forall eff. Aff (net :: NET | eff) (Result a)
type CmdR a b = forall eff. Aff (net :: NET | eff) (Result (Either a b))

sendCommandG :: forall i oe o. (EncodeJson i, DecodeJson oe, DecodeJson o) =>
                Int -> i -> (String -> Result (Either oe o)) -> CmdR oe o
sendCommandG port command unwrapper =
  makeAff (\err succ ->
            send (show (encodeJson command)) port (unwrapper >>> succ) err)

sendCommandR :: forall i oe o. (EncodeJson i, DecodeJson oe, DecodeJson o) => Int -> i -> CmdR oe o
sendCommandR port command = sendCommandG port command unwrapResponse

sendCommand :: forall i o. (EncodeJson i, DecodeJson o) => i -> Cmd o
sendCommand command =
  makeAff (\err succ ->
            send (show (encodeJson command)) 4242 (unwrapResponse >>> join >>> succ) err)

cwd :: Cmd Message
cwd = sendCommand Cwd

listLoadedModules :: Cmd ModuleList
listLoadedModules = sendCommand (Ls LoadedModules)

listAvailableModules :: Cmd ModuleList
listAvailableModules = sendCommand (Ls AvailableModules)

listImports :: String -> Cmd ImportList
listImports fp = sendCommand (Ls (Imports fp))

load ::
  Array String ->
  Array String ->
  Cmd Message
load ms ds = sendCommand (Load ms ds)

quit :: Cmd Message
quit = sendCommand Quit

pursuitCompletion :: String -> Cmd (Array PursuitCompletion)
pursuitCompletion q = sendCommand (Pursuit Ident q)

complete ::
  Array Filter ->
  Maybe Matcher ->
  Cmd (Array Completion)
complete fs m = sendCommand (Complete fs m)

type' ::
  String ->
  Array Filter ->
  Cmd (Array Completion)
type' s fs = sendCommand (Type s fs)

suggestTypos ::
  String ->
  Int ->
  Cmd (Array Completion)
suggestTypos q m = (_ <|> pure []) <$> complete [] (Just (Distance q m))

addClause :: String -> Boolean -> Cmd (Array String)
addClause line annotations = sendCommand (AddClause line annotations)

caseSplit :: String -> Int -> Int -> Boolean -> String -> Cmd (Array String)
caseSplit line begin end annotations typ =
  sendCommand (CaseSplit line begin end annotations typ)

implicitImport :: String -> (Maybe String) -> (Array Filter) -> String -> Cmd (ImportResult)
implicitImport infile outfile filters mod = sendCommand (ImportCmd infile outfile filters (AddImplicitImport mod))

explicitImport :: String -> (Maybe String) -> (Array Filter) -> String -> Cmd (ImportResult)
explicitImport infile outfile filters ident = sendCommand (ImportCmd infile outfile filters (AddImport ident))

rebuild :: Int -> String -> CmdR RebuildResult RebuildResult
rebuild port file = sendCommandR port (RebuildCmd file)


Don't add duplicate classes

Don't add duplicate classes

This can lead to a large complexity reduction, in particular as long
as we use a List.

Original commit 5b67889d0f0d227531e525d31a149447f6efead0

module IR where

import Control.Monad.State
import Control.Monad.State.Class
import Prelude

import Data.Either (Either(..), isLeft)
import Data.Foldable (find, all, any, for_, foldM)
import Data.List (List(..), concatMap, elemIndex, length, mapWithIndex, singleton, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), fromJust)
import Data.Set (Set, empty, fromFoldable)
import Data.Set as S
import Data.Tuple (Tuple(..))
import Data.Tuple as T
import Partial.Unsafe (unsafePartial)

newtype IRGraph = IRGraph { classes :: List (Either IRClassData Int) }

newtype IRClassData = IRClassData { names :: Set String, properties :: Map String IRType }

data IRType
    = IRNothing
    | IRNull
    | IRInteger
    | IRDouble
    | IRBool
    | IRString
    | IRArray IRType
    | IRClass Int
    | IRUnion (Set IRType)

derive instance eqIRType :: Eq IRType
derive instance ordIRType :: Ord IRType

makeClass :: String -> Map String IRType -> IRClassData
makeClass name properties =
    IRClassData { names: S.singleton name, properties }

emptyGraph :: IRGraph
emptyGraph = IRGraph { classes: L.Nil }

addClassWithIndex :: IRClassData -> State IRGraph (Tuple Int IRType)
addClassWithIndex classData =
    do
        IRGraph { classes } <- get
        case elemIndex (Left classData) classes of
            Nothing ->
                do
                    let index = L.length classes
                    put (IRGraph { classes: (L.snoc classes (Left classData)) })
                    pure $ Tuple index (IRClass index)
            Just index ->
                pure $ Tuple index (IRClass index)

addClass :: IRClassData -> State IRGraph IRType
addClass classData =
    do
        Tuple _ t <- addClassWithIndex classData
        pure t

followIndex :: IRGraph -> Int -> Tuple Int IRClassData
followIndex graph@(IRGraph { classes }) index =
    case unsafePartial $ fromJust $ L.index classes index of
    Left cd -> Tuple index cd
    Right i -> followIndex graph i

redirectClass :: Int -> Int -> State IRGraph Unit
redirectClass from to =
    do
        graph@(IRGraph { classes: c1 }) <- get
        let realTo = T.fst $ followIndex graph to
        if from == realTo
            then
                pure unit
            else
                do
                    let c2 = unsafePartial $ fromJust $ L.updateAt from (Right realTo) c1
                    put (IRGraph { classes: c2 })

getClassFromGraph :: IRGraph -> Int -> IRClassData
getClassFromGraph graph index =
    T.snd $ followIndex graph index

getClass :: Int -> State IRGraph IRClassData
getClass index =
    do
        graph <- get
        pure $ getClassFromGraph graph index

combineClasses :: Int -> Int -> IRClassData -> State IRGraph IRType
combineClasses ia ib combined =
    do
        IRGraph { classes } <- get
        Tuple newIndex t <- addClassWithIndex combined
        -- FIXME: could newIndex be ia or ib?
        redirectClass ia newIndex
        redirectClass ib newIndex
        pure t

mapClasses :: forall a. (Int -> IRClassData -> a) -> IRGraph -> List a
mapClasses f (IRGraph { classes }) =
    L.concat $ L.mapWithIndex mapper classes
    where
        mapper i e =
            case e of
            Left cd -> L.singleton $ f i cd
            Right _ -> L.Nil

classesInGraph :: IRGraph -> List IRClassData
classesInGraph  =
    mapClasses (\i cd -> cd)

lookupOrDefault :: forall k v. Ord k => v -> k -> Map k v -> v
lookupOrDefault default key m =
    case M.lookup key m of
    Nothing -> default
    Just x -> x

removeElement :: forall a. Ord a => (a -> Boolean) -> S.Set a -> { element :: Maybe a, rest :: S.Set a }
removeElement p s =
    let element = (find p s)
    in
        case element of
            Just x -> { element: element, rest: S.delete x s }
            Nothing -> { element: element, rest: s }

mapM :: forall a b. (a -> State IRGraph b) -> List a -> State IRGraph (List b)
mapM _ L.Nil = pure L.Nil
mapM f (x : xs) =
    do
        ys <- mapM f xs
        y <- f x
        pure $ y : ys

-- FIXME: this is ugly and inefficient
unionWithDefault :: forall k v. Ord k => (v -> v -> State IRGraph v) -> v -> Map k v -> Map k v -> State IRGraph (Map k v)
unionWithDefault unifier default m1 m2 =
    let allKeys = L.fromFoldable $ S.union (S.fromFoldable $ M.keys m1) (S.fromFoldable $ M.keys m2)
        valueFor k = unifier (lookupOrDefault default k m1) (lookupOrDefault default k m2)
        keyMapper k =
            do
                v <- valueFor k
                pure $ Tuple k v
    in
        do
            kvps <- mapM keyMapper allKeys
            pure $ M.fromFoldable kvps

isArray :: IRType -> Boolean
isArray (IRArray _) = true
isArray _ = false

isClass :: IRType -> Boolean
isClass (IRClass _) = true
isClass _ = false

decomposeTypeSet :: S.Set IRType -> { maybeArray :: Maybe IRType, maybeClass :: Maybe IRType, rest :: S.Set IRType }
decomposeTypeSet s =
    let { element: maybeArray, rest: rest } = removeElement isArray s
        { element: maybeClass, rest: rest } = removeElement isClass rest
    in
        { maybeArray, maybeClass, rest }

setFromType :: IRType -> S.Set IRType
setFromType IRNothing = S.empty
setFromType x = S.singleton x

unifyClasses :: IRClassData -> IRClassData -> State IRGraph IRClassData
unifyClasses (IRClassData { names: na, properties: pa }) (IRClassData { names: nb, properties: pb }) =
    do
        properties <- unionWithDefault unifyTypesWithNull IRNothing pa pb
        pure $ IRClassData { names: (S.union na nb), properties: properties }

unifyMaybes :: Maybe IRType -> Maybe IRType -> State IRGraph IRType
unifyMaybes Nothing Nothing = pure IRNothing
unifyMaybes (Just a) Nothing = pure a
unifyMaybes Nothing (Just b) = pure b
unifyMaybes (Just a) (Just b) = unifyTypes a b

unifyUnion :: S.Set IRType -> S.Set IRType -> State IRGraph (S.Set IRType)
unifyUnion sa sb =
    do
        let { maybeArray: arrayA, maybeClass: classA, rest: sa } = decomposeTypeSet sa
        let { maybeArray: arrayB, maybeClass: classB, rest: sb } = decomposeTypeSet sb
        unifiedArray <- unifyMaybes arrayA arrayB
        unifiedClasses <- unifyMaybes classA classB
        pure $ S.unions [sa, sb, setFromType unifiedArray, setFromType unifiedClasses]

unifyTypes :: IRType -> IRType -> State IRGraph IRType
unifyTypes IRNothing x = pure x
unifyTypes x IRNothing = pure x
unifyTypes (IRArray a) (IRArray b) =
    do
        unified <- unifyTypes a b
        pure $ IRArray unified
unifyTypes a@(IRClass ia) (IRClass ib) =
    if ia == ib then
        pure a
    else
        do
            a <- getClass ia
            b <- getClass ib
            unified <- unifyClasses a b
            combineClasses ia ib unified
unifyTypes (IRUnion a) (IRUnion b) =
    do
        unified <- unifyUnion a b
        pure $ IRUnion unified
unifyTypes (IRUnion a) b =
    do
        unified <- unifyUnion a (S.singleton b)
        pure $ IRUnion unified
unifyTypes a (IRUnion b) =
    do
        unified <- unifyUnion (S.singleton a) b
        pure $ IRUnion unified
unifyTypes a b =
    do
        pure $ if a == b then a else IRUnion (S.fromFoldable [a, b])

nullifyNothing :: IRType -> IRType
nullifyNothing IRNothing = IRNull
nullifyNothing x = x

unifyTypesWithNull :: IRType -> IRType -> State IRGraph IRType
unifyTypesWithNull IRNothing IRNothing = pure IRNothing
unifyTypesWithNull a b = unifyTypes (nullifyNothing a) (nullifyNothing b)

matchingProperties :: forall v. Eq v => Map String v -> Map String v -> Map String v
matchingProperties ma mb =
    M.fromFoldable (L.concatMap getFromB (M.toUnfoldable ma))
    where
        getFromB (Tuple k va) =
            case M.lookup k mb of
            Just vb -> if va == vb then Tuple k vb : L.Nil else L.Nil
            Nothing -> L.Nil

propertiesSimilar :: forall v. Eq v => Map String v -> Map String v -> Boolean
propertiesSimilar pa pb =
    let aInB = M.size $ matchingProperties pa pb
        bInA = M.size $ matchingProperties pb pa
    in
        (aInB * 4 >= (M.size pa) * 3) && (bInA * 4 >= (M.size pb) * 3)

isMaybeSubtypeOfMaybe :: IRGraph -> Maybe IRType -> Maybe IRType -> Boolean
isMaybeSubtypeOfMaybe _ Nothing Nothing = true
isMaybeSubtypeOfMaybe graph (Just a) (Just b) = isSubtypeOf graph a b
isMaybeSubtypeOfMaybe _ _ _ = false

isSubtypeOf :: IRGraph ->  IRType -> IRType -> Boolean
isSubtypeOf _ IRNothing _ = true
isSubtypeOf graph (IRUnion sa) (IRUnion sb) =
    all (\ta -> any (isSubtypeOf graph ta) sb) sa
isSubtypeOf graph (IRArray a) (IRArray b) =
    isSubtypeOf graph a b
isSubtypeOf graph (IRClass ia) (IRClass ib) =
    let IRClassData { names: _, properties: pa } = getClassFromGraph graph ia
        IRClassData { names: _, properties: pb } = getClassFromGraph graph ib
    in
        propertiesAreSubset graph pa pb
isSubtypeOf _ a b = a == b

propertiesAreSubset :: IRGraph -> Map String IRType -> Map String IRType -> Boolean
propertiesAreSubset graph ma mb =
    all isInB (M.toUnfoldable ma :: List _)
    where
        isInB (Tuple n ta) =
            case M.lookup n mb of
            Nothing -> false
            Just tb -> isSubtypeOf graph ta tb

classesSimilar :: IRGraph -> IRClassData -> IRClassData -> Boolean
classesSimilar graph (IRClassData { names: _, properties: pa }) (IRClassData { names: _, properties: pb }) =
    propertiesSimilar pa pb --||
    --propertiesAreSubset graph pa pb ||
    --propertiesAreSubset graph pb pa

similarClasses :: IRGraph -> Set (Set Int)
similarClasses graph@(IRGraph { classes }) =
    accumulate (mapClasses Tuple graph)
    where
        accumulate :: List (Tuple Int IRClassData) -> Set (Set Int)
        accumulate L.Nil = S.empty
        accumulate ((Tuple i thisClass) : rest) =
            let { yes: similar, no: others } = L.partition (isSimilar thisClass) rest
                recursiveResult = accumulate others
            in
                if L.length similar == 0 then
                    recursiveResult
                else
                    let similarSet = S.fromFoldable (i : (map T.fst similar))
                    in
                        S.insert similarSet recursiveResult
        isSimilar cd1 (Tuple _ cd2) =
            classesSimilar graph cd1 cd2

unifySetOfClasses :: Set Int -> (State IRGraph Unit)
unifySetOfClasses indexes =
    case L.fromFoldable indexes of
    L.Nil -> pure unit
    _ : L.Nil -> pure unit
    first : rest ->
        do
            firstClass <- getClass first
            combined <- foldM folder firstClass rest
            Tuple newIndex _ <- addClassWithIndex combined
            for_ indexes \i -> do
                redirectClass i newIndex
    where
        folder cd1 i2 =
            do
                cd2 <- getClass i2
                unifyClasses cd1 cd2

replaceSimilarClasses :: State IRGraph Unit
replaceSimilarClasses =
    do
        graph <- get
        let similar = similarClasses graph
        for_ similar unifySetOfClasses

combineNames :: S.Set String -> String
combineNames s =
    case L.fromFoldable s of
    L.Nil -> "NONAME"
    n : _ -> n

module IR where

import Control.Monad.State
import Control.Monad.State.Class
import Prelude

import Data.Either (Either(..), isLeft)
import Data.Foldable (find, all, any, for_, foldM)
import Data.List (List(..), concatMap, length, mapWithIndex, singleton, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), fromJust)
import Data.Set (Set, empty, fromFoldable)
import Data.Set as S
import Data.Tuple (Tuple(..))
import Data.Tuple as T
import Partial.Unsafe (unsafePartial)

newtype IRGraph = IRGraph { classes :: List (Either IRClassData Int) }

newtype IRClassData = IRClassData { names :: Set String, properties :: Map String IRType }

data IRType
    = IRNothing
    | IRNull
    | IRInteger
    | IRDouble
    | IRBool
    | IRString
    | IRArray IRType
    | IRClass Int
    | IRUnion (Set IRType)

derive instance eqIRType :: Eq IRType
derive instance ordIRType :: Ord IRType

makeClass :: String -> Map String IRType -> IRClassData
makeClass name properties =
    IRClassData { names: S.singleton name, properties }

emptyGraph :: IRGraph
emptyGraph = IRGraph { classes: L.Nil }

addClassWithIndex :: IRClassData -> State IRGraph (Tuple Int IRType)
addClassWithIndex classData =
    do
        IRGraph { classes } <- get
        let index = L.length classes
        put (IRGraph { classes: (L.snoc classes (Left classData)) })
        pure $ Tuple index (IRClass index)

addClass :: IRClassData -> State IRGraph IRType
addClass classData =
    do
        Tuple _ t <- addClassWithIndex classData
        pure t

redirectClass :: Int -> Int -> State IRGraph Unit
redirectClass from to =
    do
        (IRGraph { classes: c1 }) <- get
        let c2 = unsafePartial $ fromJust $ L.updateAt from (Right to) c1
        put (IRGraph { classes: c2 })

getClassFromGraph :: IRGraph -> Int -> IRClassData
getClassFromGraph graph@(IRGraph { classes }) index =
    case unsafePartial $ fromJust $ L.index classes index of
    Left cd -> cd
    Right i -> getClassFromGraph graph i

getClass :: Int -> State IRGraph IRClassData
getClass index =
    do
        graph <- get
        pure $ getClassFromGraph graph index

combineClasses :: Int -> Int -> IRClassData -> State IRGraph IRType
combineClasses ia ib combined =
    do
        IRGraph { classes } <- get
        let newIndex = L.length classes
        t <- addClass combined
        redirectClass ia newIndex
        redirectClass ib newIndex
        pure t

mapClasses :: forall a. (Int -> IRClassData -> a) -> IRGraph -> List a
mapClasses f (IRGraph { classes }) =
    L.concat $ L.mapWithIndex mapper classes
    where
        mapper i e =
            case e of
            Left cd -> L.singleton $ f i cd
            Right _ -> L.Nil

classesInGraph :: IRGraph -> List IRClassData
classesInGraph  =
    mapClasses (\i cd -> cd)

lookupOrDefault :: forall k v. Ord k => v -> k -> Map k v -> v
lookupOrDefault default key m =
    case M.lookup key m of
    Nothing -> default
    Just x -> x

removeElement :: forall a. Ord a => (a -> Boolean) -> S.Set a -> { element :: Maybe a, rest :: S.Set a }
removeElement p s =
    let element = (find p s)
    in
        case element of
            Just x -> { element: element, rest: S.delete x s }
            Nothing -> { element: element, rest: s }

mapM :: forall a b. (a -> State IRGraph b) -> List a -> State IRGraph (List b)
mapM _ L.Nil = pure L.Nil
mapM f (x : xs) =
    do
        ys <- mapM f xs
        y <- f x
        pure $ y : ys

-- FIXME: this is ugly and inefficient
unionWithDefault :: forall k v. Ord k => (v -> v -> State IRGraph v) -> v -> Map k v -> Map k v -> State IRGraph (Map k v)
unionWithDefault unifier default m1 m2 =
    let allKeys = L.fromFoldable $ S.union (S.fromFoldable $ M.keys m1) (S.fromFoldable $ M.keys m2)
        valueFor k = unifier (lookupOrDefault default k m1) (lookupOrDefault default k m2)
        keyMapper k =
            do
                v <- valueFor k
                pure $ Tuple k v
    in
        do
            kvps <- mapM keyMapper allKeys
            pure $ M.fromFoldable kvps

isArray :: IRType -> Boolean
isArray (IRArray _) = true
isArray _ = false

isClass :: IRType -> Boolean
isClass (IRClass _) = true
isClass _ = false

decomposeTypeSet :: S.Set IRType -> { maybeArray :: Maybe IRType, maybeClass :: Maybe IRType, rest :: S.Set IRType }
decomposeTypeSet s =
    let { element: maybeArray, rest: rest } = removeElement isArray s
        { element: maybeClass, rest: rest } = removeElement isClass rest
    in
        { maybeArray, maybeClass, rest }

setFromType :: IRType -> S.Set IRType
setFromType IRNothing = S.empty
setFromType x = S.singleton x

unifyClasses :: IRClassData -> IRClassData -> State IRGraph IRClassData
unifyClasses (IRClassData { names: na, properties: pa }) (IRClassData { names: nb, properties: pb }) =
    do
        properties <- unionWithDefault unifyTypesWithNull IRNothing pa pb
        pure $ IRClassData { names: (S.union na nb), properties: properties }

unifyMaybes :: Maybe IRType -> Maybe IRType -> State IRGraph IRType
unifyMaybes Nothing Nothing = pure IRNothing
unifyMaybes (Just a) Nothing = pure a
unifyMaybes Nothing (Just b) = pure b
unifyMaybes (Just a) (Just b) = unifyTypes a b

unifyUnion :: S.Set IRType -> S.Set IRType -> State IRGraph (S.Set IRType)
unifyUnion sa sb =
    do
        let { maybeArray: arrayA, maybeClass: classA, rest: sa } = decomposeTypeSet sa
        let { maybeArray: arrayB, maybeClass: classB, rest: sb } = decomposeTypeSet sb
        unifiedArray <- unifyMaybes arrayA arrayB
        unifiedClasses <- unifyMaybes classA classB
        pure $ S.unions [sa, sb, setFromType unifiedArray, setFromType unifiedClasses]

unifyTypes :: IRType -> IRType -> State IRGraph IRType
unifyTypes IRNothing x = pure x
unifyTypes x IRNothing = pure x
unifyTypes (IRArray a) (IRArray b) =
    do
        unified <- unifyTypes a b
        pure $ IRArray unified
unifyTypes (IRClass ia) (IRClass ib) =
    do
        a <- getClass ia
        b <- getClass ib
        unified <- unifyClasses a b
        combineClasses ia ib unified
unifyTypes (IRUnion a) (IRUnion b) =
    do
        unified <- unifyUnion a b
        pure $ IRUnion unified
unifyTypes (IRUnion a) b =
    do
        unified <- unifyUnion a (S.singleton b)
        pure $ IRUnion unified
unifyTypes a (IRUnion b) =
    do
        unified <- unifyUnion (S.singleton a) b
        pure $ IRUnion unified
unifyTypes a b =
    do
        pure $ if a == b then a else IRUnion (S.fromFoldable [a, b])

nullifyNothing :: IRType -> IRType
nullifyNothing IRNothing = IRNull
nullifyNothing x = x

unifyTypesWithNull :: IRType -> IRType -> State IRGraph IRType
unifyTypesWithNull IRNothing IRNothing = pure IRNothing
unifyTypesWithNull a b = unifyTypes (nullifyNothing a) (nullifyNothing b)

matchingProperties :: forall v. Eq v => Map String v -> Map String v -> Map String v
matchingProperties ma mb =
    M.fromFoldable (L.concatMap getFromB (M.toUnfoldable ma))
    where
        getFromB (Tuple k va) =
            case M.lookup k mb of
            Just vb -> if va == vb then Tuple k vb : L.Nil else L.Nil
            Nothing -> L.Nil

propertiesSimilar :: forall v. Eq v => Map String v -> Map String v -> Boolean
propertiesSimilar pa pb =
    let aInB = M.size $ matchingProperties pa pb
        bInA = M.size $ matchingProperties pb pa
    in
        (aInB * 4 >= (M.size pa) * 3) && (bInA * 4 >= (M.size pb) * 3)

isMaybeSubtypeOfMaybe :: IRGraph -> Maybe IRType -> Maybe IRType -> Boolean
isMaybeSubtypeOfMaybe _ Nothing Nothing = true
isMaybeSubtypeOfMaybe graph (Just a) (Just b) = isSubtypeOf graph a b
isMaybeSubtypeOfMaybe _ _ _ = false

isSubtypeOf :: IRGraph ->  IRType -> IRType -> Boolean
isSubtypeOf _ IRNothing _ = true
isSubtypeOf graph (IRUnion sa) (IRUnion sb) =
    all (\ta -> any (isSubtypeOf graph ta) sb) sa
isSubtypeOf graph (IRArray a) (IRArray b) =
    isSubtypeOf graph a b
isSubtypeOf graph (IRClass ia) (IRClass ib) =
    let IRClassData { names: _, properties: pa } = getClassFromGraph graph ia
        IRClassData { names: _, properties: pb } = getClassFromGraph graph ib
    in
        propertiesAreSubset graph pa pb
isSubtypeOf _ a b = a == b

propertiesAreSubset :: IRGraph -> Map String IRType -> Map String IRType -> Boolean
propertiesAreSubset graph ma mb =
    all isInB (M.toUnfoldable ma :: List _)
    where
        isInB (Tuple n ta) =
            case M.lookup n mb of
            Nothing -> false
            Just tb -> isSubtypeOf graph ta tb

classesSimilar :: IRGraph -> IRClassData -> IRClassData -> Boolean
classesSimilar graph (IRClassData { names: _, properties: pa }) (IRClassData { names: _, properties: pb }) =
    propertiesSimilar pa pb --||
    --propertiesAreSubset graph pa pb ||
    --propertiesAreSubset graph pb pa

similarClasses :: IRGraph -> Set (Set Int)
similarClasses graph@(IRGraph { classes }) =
    accumulate (mapClasses Tuple graph)
    where
        accumulate :: List (Tuple Int IRClassData) -> Set (Set Int)
        accumulate L.Nil = S.empty
        accumulate ((Tuple i thisClass) : rest) =
            let { yes: similar, no: others } = L.partition (isSimilar thisClass) rest
                recursiveResult = accumulate others
            in
                if L.length similar == 0 then
                    recursiveResult
                else
                    let similarSet = S.fromFoldable (i : (map T.fst similar))
                    in
                        S.insert similarSet recursiveResult
        isSimilar cd1 (Tuple _ cd2) =
            classesSimilar graph cd1 cd2

unifySetOfClasses :: Set Int -> (State IRGraph Unit)
unifySetOfClasses indexes =
    case L.fromFoldable indexes of
    L.Nil -> pure unit
    _ : L.Nil -> pure unit
    first : rest ->
        do
            firstClass <- getClass first
            combined <- foldM folder firstClass rest
            Tuple newIndex _ <- addClassWithIndex combined
            for_ indexes \i -> do
                redirectClass i newIndex
    where
        folder cd1 i2 =
            do
                cd2 <- getClass i2
                unifyClasses cd1 cd2

replaceSimilarClasses :: State IRGraph Unit
replaceSimilarClasses =
    do
        graph <- get
        let similar = similarClasses graph
        for_ similar unifySetOfClasses

combineNames :: S.Set String -> String
combineNames s =
    case L.fromFoldable s of
    L.Nil -> "NONAME"
    n : _ -> n