submit on enter

submit on enter

module Component.Chat where

import Prelude
import WebAPI.Settings
import WebAPI
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Servant.Subscriber as Subscribe
import Signal.Channel as Chan
import WebAPI.Subscriber as Sub
import CSS.Transform (offset)
import Control.Category ((<<<))
import Control.Monad (class Monad, pure, bind)
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Aff.Console (error)
import Control.Monad.Aff.Free (class Affable)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Except (runExceptT)
import Control.Monad.Reader (runReaderT)
import Data.Either (Either(..))
import Data.Function (const, (<<<))
import Data.Generic (gCompare, gShow)
import Data.Maybe (Maybe(..), maybe, maybe')
import Data.Monoid (append)
import Data.NaturalTransformation (type (~>))
import Data.Semigroup ((<>))
import Data.String (take)
import Halogen (Component, ComponentDSL, ComponentHTML, EventSource, HalogenEffects, action, eventSource, liftH, modify, subscribe)
import Halogen.Component (lifecycleComponent)
import Halogen.HTML.Events (onChange)
import Halogen.HTML.Events.Indexed (input_, onClick, onInput, onKeyPress, onSubmit)
import Halogen.HTML.Indexed (button, input, textarea)
import Halogen.Query (get, set)
import Network.HTTP.Affjax (AJAX)
import Servant.PureScript.Affjax (errorToString)
import Servant.Subscriber (Subscriber, SubscriberEff, makeSubscriber)
import Servant.Subscriber.Connection (Config)
import Servant.Subscriber.Internal (doCallback)
import Signal (Signal, runSignal)
import Signal.Channel (Channel, send, channel, CHANNEL)
import WebAPI.Subscriber (getGame)
import WebSocket (WEBSOCKET)

type State = {cur :: String , text :: Array String}

initial :: State
initial = {cur: "", text: []}

data Query a = Connect a | Disconnect a | UpdateText String a | SendMessage a | UpdateCurrent String a

type Effects  eff = (ajax :: AJAX, channel :: CHANNEL, ref :: REF, ws :: WEBSOCKET | eff)

onlyForKey :: forall props g ev.
  (Functor g) => Number
                   -> ({ "keyCode" :: Number
                       | props
                       }
                       -> g (Maybe ev)
                      )
                      -> { "keyCode" :: Number
                         | props
                         }
                         -> g (Maybe ev)
onlyForKey i input  = (\ (a@{keyCode}) -> (if keyCode == 13.0 then id else const Nothing) <$> input a)

chat :: forall g eff. (Monad g, Affable (HalogenEffects(Effects eff)) g, MonadAff (HalogenEffects(Effects eff)) g) => Component State Query g
chat = lifecycleComponent {render, eval, initializer: Just (action Connect), finalizer: Just (action Disconnect)}
        where
              render :: State -> ComponentHTML Query
              render {text, cur} = H.div_ $
                    append [ H.input [ P.value cur
                                     , E.onValueInput (E.input UpdateCurrent)
                                     , E.onKeyPress  (onlyForKey 13.0 (E.input_ SendMessage))
                                     ]
                            , H.button [E.onClick (E.input_ SendMessage)] [H.text "Send"]]
                        $ (\t -> H.div_ [H.text t]) <$> text

              eval :: Query ~> (ComponentDSL State Query g)
              eval (Connect a) = do
                subscribe chatMessages
                pure a
              eval (Disconnect a) = pure a
              eval (UpdateText t a) = do
                modify (\s ->  s {text= append [t] s.text})
                pure a
              eval (SendMessage a) = do
                st <- get
                merr <- liftH <<< liftAff $ sendMessage st.cur
                case merr of
                    Just err -> do modify (\s ->  s {text= append [err] s.text})
                                   pure a
                    Nothing -> do set {cur: "", text: st.text}
                                  pure a
              eval (UpdateCurrent s a) = do
                modify (\st -> st {cur = s})
                pure a

data Action = Update String
            | ReportError
            | SubscriberLog String
            | Nop

type SubscriberData eff = {
  subscriber :: Subscriber eff Action
, messages :: Signal Action
}

initSubscriber :: forall eff. SubscriberEff (channel :: CHANNEL | eff) (SubscriberData (channel :: CHANNEL | eff))
initSubscriber = do
  ch <- channel Nop
  let
    c :: Config (channel :: CHANNEL | eff) Action
    c = {
        url : "ws://localhost:8080/subscriber"
      , notify : send ch <<< SubscriberLog <<< gShow
      , callback : send ch
      }
  sub <- makeSubscriber c
  let sig = Chan.subscribe ch
  --pongReq <- flip runReaderT settings $ MakeReq.putCounter (CounterAdd 1) -- | Let's play a bit! :-)
  -- closeReq <- flip runReaderT settings $ MakeReq.putCounter (CounterSet 100)
  subs <- flip runReaderT settings $ Sub.getGame (maybe (ReportError) Update)
  let conn = Subscribe.getConnection sub
 -- C.setPongRequest pongReq conn -- |< Hihi :-)
 -- C.setCloseRequest closeReq conn
  Subscribe.deploy subs sub
  pure $ { subscriber : sub, messages : sig }

callback :: forall eff.
  (Action -> Eff
       ( "ref" :: REF
       , "ws" :: WEBSOCKET
       , "err" :: EXCEPTION
       , "channel" :: CHANNEL
       | eff
       ) Unit  )
  -> Eff
       ( "ref" :: REF
       , "ws" :: WEBSOCKET
       , "err" :: EXCEPTION
       , "channel" :: CHANNEL
       | eff
       )
       Unit
callback eff = do
    s <- initSubscriber
    runSignal (eff <$> s.messages)

chatMessages ::  forall g eff. (Monad g, Affable (HalogenEffects(Effects eff)) g) => EventSource Query g
chatMessages = eventSource callback (\a -> case a of
            Update s -> f $ UpdateText s
            Nop -> f $ UpdateText "No op"
            ReportError -> f $ UpdateText "Error"
            SubscriberLog s -> f $ UpdateText s
        )
        where
            f x = pure $ action x

sendMessage :: forall eff. String -> Aff (ajax :: AJAX | eff) (Maybe String)
sendMessage s = do
    ebs <- runExceptT $ runReaderT (postGame s) settings
    pure $ case ebs of
        Left err -> Just $ errorToString err
        _ -> Nothing

module Component.Chat where

import Prelude
import WebAPI.Settings
import WebAPI
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Servant.Subscriber as Subscribe
import Signal.Channel as Chan
import WebAPI.Subscriber as Sub
import CSS.Transform (offset)
import Control.Category ((<<<))
import Control.Monad (class Monad, pure, bind)
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Aff.Console (error)
import Control.Monad.Aff.Free (class Affable)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Except (runExceptT)
import Control.Monad.Reader (runReaderT)
import Data.Either (Either(..))
import Data.Function ((<<<))
import Data.Generic (gCompare, gShow)
import Data.Maybe (Maybe(..), maybe, maybe')
import Data.Monoid (append)
import Data.NaturalTransformation (type (~>))
import Halogen (Component, ComponentDSL, ComponentHTML, EventSource, HalogenEffects, action, eventSource, liftH, modify, subscribe)
import Halogen.Component (lifecycleComponent)
import Halogen.HTML.Events (onChange)
import Halogen.HTML.Events.Indexed (input_, onClick)
import Halogen.HTML.Indexed (button, input, textarea)
import Halogen.Query (get, set)
import Network.HTTP.Affjax (AJAX)
import Servant.PureScript.Affjax (errorToString)
import Servant.Subscriber (Subscriber, SubscriberEff, makeSubscriber)
import Servant.Subscriber.Connection (Config)
import Servant.Subscriber.Internal (doCallback)
import Signal (Signal, runSignal)
import Signal.Channel (Channel, send, channel, CHANNEL)
import WebAPI.Subscriber (getGame)
import WebSocket (WEBSOCKET)

type State = {cur :: String , text :: Array String}

initial :: State
initial = {cur: "", text: []}

data Query a = Connect a | Disconnect a | UpdateText String a | SendMessage a | UpdateCurrent String a

type Effects  eff = (ajax :: AJAX, channel :: CHANNEL, ref :: REF, ws :: WEBSOCKET | eff)

chat :: forall g eff. (Monad g, Affable (HalogenEffects(Effects eff)) g, MonadAff (HalogenEffects(Effects eff)) g) => Component State Query g
chat = lifecycleComponent {render, eval, initializer: Just (action Connect), finalizer: Just (action Disconnect)}
        where
              render :: State -> ComponentHTML Query
              render {text, cur} = H.div_ $
                append [ H.input [P.value cur, E.onValueChange (E.input UpdateCurrent)]
                       , H.button [E.onClick (E.input_ SendMessage)] [H.text "Send"]]
                $ (\t -> H.div_ [H.text t]) <$> text
              eval :: Query ~> (ComponentDSL State Query g)
              eval (Connect a) = do
                subscribe chatMessages
                pure a
              eval (Disconnect a) = pure a
              eval (UpdateText t a) = do
                modify (\s ->  s {text= append [t] s.text})
                pure a
              eval (SendMessage a) = do
                st <- get
                merr <- liftH <<< liftAff $ sendMessage st.cur
                case merr of
                    Just err -> do modify (\s ->  s {text= append [err] s.text})
                                   pure a
                    Nothing -> do set {cur: "", text: st.text}
                                  pure a
              eval (UpdateCurrent s a) = do
                modify (\st -> st {cur = s})
                pure a

data Action = Update String
            | ReportError
            | SubscriberLog String
            | Nop

type SubscriberData eff = {
  subscriber :: Subscriber eff Action
, messages :: Signal Action
}

initSubscriber :: forall eff. SubscriberEff (channel :: CHANNEL | eff) (SubscriberData (channel :: CHANNEL | eff))
initSubscriber = do
  ch <- channel Nop
  let
    c :: Config (channel :: CHANNEL | eff) Action
    c = {
        url : "ws://localhost:8080/subscriber"
      , notify : send ch <<< SubscriberLog <<< gShow
      , callback : send ch
      }
  sub <- makeSubscriber c
  let sig = Chan.subscribe ch
  --pongReq <- flip runReaderT settings $ MakeReq.putCounter (CounterAdd 1) -- | Let's play a bit! :-)
  -- closeReq <- flip runReaderT settings $ MakeReq.putCounter (CounterSet 100)
  subs <- flip runReaderT settings $ Sub.getGame (maybe (ReportError) Update)
  let conn = Subscribe.getConnection sub
 -- C.setPongRequest pongReq conn -- |< Hihi :-)
 -- C.setCloseRequest closeReq conn
  Subscribe.deploy subs sub
  pure $ { subscriber : sub, messages : sig }

callback :: forall eff.
  (Action -> Eff
       ( "ref" :: REF
       , "ws" :: WEBSOCKET
       , "err" :: EXCEPTION
       , "channel" :: CHANNEL
       | eff
       ) Unit  )
  -> Eff
       ( "ref" :: REF
       , "ws" :: WEBSOCKET
       , "err" :: EXCEPTION
       , "channel" :: CHANNEL
       | eff
       )
       Unit
callback eff = do
    s <- initSubscriber
    runSignal (eff <$> s.messages)

chatMessages ::  forall g eff. (Monad g, Affable (HalogenEffects(Effects eff)) g) => EventSource Query g
chatMessages = eventSource callback (\a -> case a of
            Update s -> f $ UpdateText s
            Nop -> f $ UpdateText "No op"
            ReportError -> f $ UpdateText "Error"
            SubscriberLog s -> f $ UpdateText s
        )
        where
            f x = pure $ action x

sendMessage :: forall eff. String -> Aff (ajax :: AJAX | eff) (Maybe String)
sendMessage s = do
    ebs <- runExceptT $ runReaderT (postGame s) settings
    pure $ case ebs of
        Left err -> Just $ errorToString err
        _ -> Nothing


Export Elm union constructors. Fixes #225

module Language.Elm
    ( renderer
    ) where

import Prelude

import Data.Array as A
import Data.Foldable (for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.String.Util (camelCase, capitalize, decapitalize, isLetterOrUnderscore, isLetterOrUnderscoreOrDigit, legalizeCharacters, startWithLetter, stringEscape)
import Data.Tuple (Tuple(..), fst)
import Doc (Doc, Namer, Renderer, blank, combineNames, forEachTopLevel_, getClasses, getOptionValue, getTopLevelNames, getTopLevels, getTypeNameForUnion, getUnions, indent, line, lookupClassName, lookupName, lookupUnionName, renderRenderItems, simpleNamer, transformPropertyNames, unionIsNotSimpleNullable, unionNameIntercalated, unlessOption, whenOption)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, isArray, nullableFromUnion, unionToList)
import Options (Option, enumOption, stringOption)
import Utils (forEnumerated_, sortByKey, sortByKeyM, mapM)

forbiddenNames :: Array String
forbiddenNames =
    [ "if", "then", "else"
    , "case", "of"
    , "let", "in"
    , "type"
    , "module", "where"
    , "import", "exposing"
    , "as"
    , "port"
    , "int", "float", "bool", "string"
    , "Jenc", "Jdec", "Jpipe"
    , "always", "identity"
    , "Array", "Dict", "Maybe", "map", "toList"
    , "makeArrayEncoder", "makeDictEncoder", "makeNullableEncoder"
    ]

listOption :: Option Boolean
listOption = enumOption "array-type" "Use Array or List" [Tuple "array" false, Tuple "list" true]

moduleOption :: Option String
moduleOption = stringOption "module" "Generated module name" "NAME" "QuickType"

renderer :: Renderer
renderer =
    { displayName: "Elm"
    , names: [ "elm" ]
    , aceMode: "elm"
    , extension: "elm"
    , doc: elmDoc
    , options:
        [ moduleOption.specification
        , listOption.specification
        ]
    , transforms:
        { nameForClass: elmNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelName: elmNamer upperNameStyle
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: elmNamer (upperNameStyle <<< combineNames)
            , nameFromTypes: elmNamer (unionNameIntercalated upperNameStyle "Or")
            }
        }
    }

decoderNameFromTypeName :: String -> String
decoderNameFromTypeName = decapitalize

encoderNameFromTypeName :: String -> String
encoderNameFromTypeName className = "encode" <> className

alsoForbiddenForTypeName :: String -> Array String
alsoForbiddenForTypeName n = [decoderNameFromTypeName n, encoderNameFromTypeName n]

elmNamer :: forall a. Ord a => (a -> String) -> Namer a
elmNamer namer thing = case _ of
    Just name -> result name
    Nothing -> result $ namer thing
    where
        result name = { name, forbid: A.cons name $ alsoForbiddenForTypeName name }

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

typeNameForTopLevelNameGiven :: String -> String
typeNameForTopLevelNameGiven = upperNameStyle

namesFromTopLevelNameGiven :: String -> Array String
namesFromTopLevelNameGiven given =
    let name = typeNameForTopLevelNameGiven given
    in A.cons name $ alsoForbiddenForTypeName name

legalize :: String -> String
legalize = legalizeCharacters isLetterOrUnderscoreOrDigit

elmNameStyle :: Boolean -> String -> String
elmNameStyle upper = legalize >>> camelCase >>> (startWithLetter isLetterOrUnderscore upper)

lowerNameStyle :: String -> String
lowerNameStyle = elmNameStyle false

upperNameStyle :: String -> String
upperNameStyle = elmNameStyle true

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

renderArrayType :: Doc String
renderArrayType = do
    useList <- getOptionValue listOption
    pure $ if useList then "List" else "Array"

elmDoc :: Doc Unit
elmDoc = do
    topLevels <- getTopLevels
    -- givenTopLevel <- typeNameForTopLevelNameGiven <$> getTopLevelNameGiven
    -- let topLevelDecoder = decoderNameFromTypeName givenTopLevel
    -- let topLevelEncoder = encoderNameFromTypeName givenTopLevel
    classes <- getClasses
    unions <- getUnions
    classNames <- mapM (\t -> lookupClassName $ fst t) classes
    unionExports <- map (\n -> n <> "(..)") <$> mapM lookupUnionName unions
    topLevelNames <- M.values <$> getTopLevelNames
    let topLevelDecoders = map decoderNameFromTypeName topLevelNames
    let alsoTopLevelExports = L.concat $ map (alsoForbiddenForTypeName >>> L.fromFoldable) topLevelNames
    let exports = L.concat $ topLevelNames : alsoTopLevelExports : classNames : unionExports : L.Nil
    moduleName <- getOptionValue moduleOption
    line """-- To decode the JSON data, add this file to your project, run
--
--     elm-package install NoRedInk/elm-decode-pipeline
--
-- add these imports
--
--     import Json.Decode exposing (decodeString)"""
    line $ "--     import " <> moduleName <> " exposing (" <> (intercalate ", " topLevelDecoders) <> ")"
    line """--
-- and you're off to the races with
--"""
    forEachTopLevel_ \topLevelName topLevelType -> do
        let topLevelDecoder = decoderNameFromTypeName topLevelName
        line $ "--     decodeString " <> topLevelDecoder <> " myJsonString"
    blank
    line $ "module " <> moduleName <> " exposing"
    indent do
        forWithPrefix_ exports "( " ", " \parenOrComma name ->
            line $ parenOrComma <> name
        line ")"
    blank
    line """import Json.Decode as Jdec
import Json.Decode.Pipeline as Jpipe
import Json.Encode as Jenc
import Dict exposing (Dict, map, toList)"""
    arrayType <- renderArrayType
    whenOption listOption do
        line $ "import List exposing (map)"
    unlessOption listOption do
        line $ "import Array exposing (Array, map)"
    blank
    renderRenderItems blank (Just renderTopLevelDefinition) (typeRenderer renderTypeDefinition) (Just renderUnionDefinition)
    blank
    line "-- decoders and encoders"
    blank
    renderRenderItems blank (Just renderTopLevelFunctions) (typeRenderer renderTypeFunctions) (Just renderUnionFunctions)
    blank
    line "--- encoder helpers"
    blank
    line $ "make" <> arrayType <> "Encoder : (a -> Jenc.Value) -> " <> arrayType <> " a -> Jenc.Value"
    line $ "make" <> arrayType <> "Encoder f arr ="
    indent do
        line $ "Jenc." <> decapitalize arrayType <> " (" <> arrayType <> ".map f arr)"
    blank
    line """makeDictEncoder : (a -> Jenc.Value) -> Dict String a -> Jenc.Value
makeDictEncoder f dict =
    Jenc.object (toList (Dict.map (\k -> f) dict))

makeNullableEncoder : (a -> Jenc.Value) -> Maybe a -> Jenc.Value
makeNullableEncoder f m =
    case m of
    Just x -> f x
    Nothing -> Jenc.null"""

renderTopLevelDefinition :: String -> IRType -> Doc Unit
renderTopLevelDefinition topLevelName topLevel = do
    { rendered: topLevelRendered } <- typeStringForType topLevel
    line $ "type alias " <> topLevelName <> " = " <> topLevelRendered

renderTopLevelFunctions :: String -> IRType -> Doc Unit
renderTopLevelFunctions topLevelName topLevel = do
    let topLevelDecoder = decoderNameFromTypeName topLevelName
    let topLevelEncoder = encoderNameFromTypeName topLevelName
    { rendered: rootDecoder } <- decoderNameForType topLevel
    line $ topLevelDecoder <> " : Jdec.Decoder " <> topLevelName
    line $ topLevelDecoder <> " = " <> rootDecoder
    blank
    { rendered: rootEncoder } <- encoderNameForType topLevel
    line $ topLevelEncoder <> " : " <> topLevelName <> " -> String"
    line $ topLevelEncoder <> " r = Jenc.encode 0 (" <> rootEncoder <> " r)"

singleWord :: String -> Doc { rendered :: String, multiWord :: Boolean }
singleWord w = pure { rendered: w, multiWord: false }

multiWord :: String -> String -> Doc { rendered :: String, multiWord :: Boolean }
multiWord s1 s2 = pure { rendered: s1 <> " " <> s2, multiWord: true }

parenIfNeeded :: { rendered :: String, multiWord :: Boolean } -> String
parenIfNeeded { rendered, multiWord: false } = rendered
parenIfNeeded { rendered, multiWord: true } = "(" <> rendered <> ")"

typeStringForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
typeStringForType = case _ of
    IRNoInformation -> singleWord "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType -> singleWord "Jdec.Value"
    IRNull -> singleWord "()"
    IRInteger -> singleWord "Int"
    IRDouble -> singleWord "Float"
    IRBool -> singleWord "Bool"
    IRString -> singleWord "String"
    IRArray a -> do
        ts <- typeStringForType a
        arrayType <- renderArrayType
        multiWord arrayType $ parenIfNeeded ts
    IRClass i -> singleWord =<< lookupClassName i
    IRMap t -> do
        ts <- typeStringForType t
        multiWord "Dict String" $ parenIfNeeded ts
    IRUnion u ->
        case nullableFromUnion u of
        Just x -> do
            ts <- typeStringForType x
            multiWord "Maybe" $ parenIfNeeded ts
        Nothing -> do
            singleWord =<< lookupUnionName u

unionConstructorName :: String -> IRType -> Doc String
unionConstructorName unionName t = do
    typeName <- upperNameStyle <$> getTypeNameForUnion t
    pure $ typeName <> "In" <> unionName

decoderNameForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
decoderNameForType = case _ of
    IRNoInformation -> singleWord "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType -> singleWord "Jdec.value"
    IRNull -> multiWord "Jdec.null" "()"
    IRInteger -> singleWord "Jdec.int"
    IRDouble -> singleWord "Jdec.float"
    IRBool -> singleWord "Jdec.bool"
    IRString -> singleWord "Jdec.string"
    IRArray a -> do
        dn <- decoderNameForType a
        arrayType <- renderArrayType
        multiWord ("Jdec." <> decapitalize arrayType) $ parenIfNeeded dn
    IRClass i -> singleWord =<< decoderNameFromTypeName <$> lookupClassName i
    IRMap t -> do
        dn <- decoderNameForType t
        multiWord "Jdec.dict" $ parenIfNeeded dn
    IRUnion u ->
        case nullableFromUnion u of
        Just t -> do
            dn <- decoderNameForType t
            multiWord "Jdec.nullable" $ parenIfNeeded dn
        Nothing -> do
            singleWord =<< decoderNameFromTypeName <$> lookupUnionName u

encoderNameForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
encoderNameForType = case _ of
    IRNoInformation -> singleWord "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType -> singleWord "identity"
    IRNull -> multiWord "always" "Jenc.null"
    IRInteger -> singleWord "Jenc.int"
    IRDouble -> singleWord "Jenc.float"
    IRBool -> singleWord "Jenc.bool"
    IRString -> singleWord "Jenc.string"
    IRArray a -> do
        rendered <- encoderNameForType a
        arrayType <- renderArrayType
        multiWord ("make" <> arrayType <> "Encoder") $ parenIfNeeded rendered
    IRClass i -> singleWord =<< encoderNameFromTypeName <$> lookupClassName i
    IRMap t -> do
        rendered <- encoderNameForType t
        multiWord "makeDictEncoder" $ parenIfNeeded rendered
    IRUnion u ->
        case nullableFromUnion u of
        Just t -> do
            rendered <- encoderNameForType t
            multiWord "makeNullableEncoder" $ parenIfNeeded rendered
        Nothing ->
            singleWord =<< encoderNameFromTypeName <$> lookupUnionName u

forWithPrefix_ :: forall a b p m. Applicative m => List a -> p -> p -> (p -> a -> m b) -> m Unit
forWithPrefix_ l firstPrefix restPrefix f =
    forEnumerated_ l (\i -> f $ if i == 0 then firstPrefix else restPrefix)

renderTypeDefinition :: String -> Map String String -> List (Tuple String IRType) -> Doc Unit
renderTypeDefinition className propertyNames propsList = do
    line $ "type alias " <> className <> " ="
    indent do
        forWithPrefix_ propsList "{ " ", " \braceOrComma (Tuple pname ptype) -> do
            let propName = lookupName pname propertyNames
            { rendered } <- typeStringForType ptype
            line $ braceOrComma <> propName <> " : " <> rendered
        when (propsList == L.Nil) do
            line "{"
        line "}"

renderTypeFunctions :: String -> Map String String -> List (Tuple String IRType) -> Doc Unit
renderTypeFunctions className propertyNames propsList = do
    let decoderName = decoderNameFromTypeName className
    line $ decoderName <> " : Jdec.Decoder " <> className
    line $ decoderName <> " ="
    indent do
        line $ "Jpipe.decode " <> className
        for_ propsList \(Tuple pname ptype) -> do
            indent do
                propDecoder <- decoderNameForType ptype
                let { reqOrOpt, fallback } = requiredOrOptional ptype
                line $ "|> " <> reqOrOpt <> " \"" <> stringEscape pname <> "\" " <> (parenIfNeeded propDecoder) <> fallback
    blank
    let encoderName = encoderNameFromTypeName className
    line $ encoderName <> " : " <> className <> " -> Jenc.Value"
    line $ encoderName <> " x ="
    indent do
        line "Jenc.object"
        indent do
            forWithPrefix_ propsList "[ " ", " \bracketOrComma (Tuple pname ptype) -> do
                let propName = lookupName pname propertyNames
                { rendered: propEncoder } <- encoderNameForType ptype
                line $ bracketOrComma <> "(\"" <> stringEscape pname <> "\", " <> propEncoder <> " x." <> propName <> ")"
            when (propsList == L.Nil) do
                line "["
            line "]"
    where
        requiredOrOptional :: IRType -> { reqOrOpt :: String, fallback :: String }
        requiredOrOptional = case _ of
            IRNull -> optional " ()"
            IRUnion u ->
                if not $ unionIsNotSimpleNullable u then
                    optional " Nothing"
                else
                    required
            _ -> required
        required =
            { reqOrOpt: "Jpipe.required", fallback: "" }
        optional fallback =
            { reqOrOpt: "Jpipe.optional", fallback }

typeRenderer :: (String -> Map String String -> List (Tuple String IRType) -> Doc Unit) -> String -> Map String IRType -> Doc Unit
typeRenderer renderer' className properties = do
    let propertyNames = transformPropertyNames (simpleNamer lowerNameStyle) (\n -> "other" <> capitalize n) forbiddenNames properties
    let propsList = M.toUnfoldable properties # sortByKey (\t -> lookupName (fst t) propertyNames)
    renderer' className propertyNames propsList

renderUnionDefinition :: String -> IRUnionRep -> Doc Unit
renderUnionDefinition unionName unionRep = do
    fields <- unionToList unionRep # sortByKeyM (unionConstructorName unionName)
    line $ "type " <> unionName
    forWithPrefix_ fields "=" "|" \equalsOrPipe t -> do
        indent do
            constructor <- unionConstructorName unionName t
            when (t == IRNull) do
                line $ equalsOrPipe <> " " <> constructor
            unless (t == IRNull) do
                ts <- typeStringForType t
                line $ equalsOrPipe <> " " <> constructor <> " " <> (parenIfNeeded ts)

renderUnionFunctions :: String -> IRUnionRep -> Doc Unit
renderUnionFunctions unionName unionRep = do
    let decoderName = decoderNameFromTypeName unionName
    line $ decoderName <> " : Jdec.Decoder " <> unionName
    line $ decoderName <> " ="
    indent do
        let decFields = L.sortBy arrayFirstOrder $ unionToList unionRep
        line "Jdec.oneOf"
        indent do
            forWithPrefix_ decFields "[" "," \bracketOrComma t -> do
                constructor <- unionConstructorName unionName t
                when (t == IRNull) do
                    line $ bracketOrComma <> " Jdec.null " <> constructor
                unless (t == IRNull) do
                    decoder <- decoderNameForType t
                    line $ bracketOrComma <> " Jdec.map " <> constructor <> " " <> parenIfNeeded decoder
            line "]"
    blank
    let encoderName = encoderNameFromTypeName unionName
    line $ encoderName <> " : " <> unionName <> " -> Jenc.Value"
    line $ encoderName <> " x = case x of"
    indent do
        fields <- unionToList unionRep # sortByKeyM (unionConstructorName unionName)
        for_ fields \t -> do
            constructor <- unionConstructorName unionName t
            when (t == IRNull) do
                line $ constructor <> " -> Jenc.null"
            unless (t == IRNull) do
                { rendered: encoder } <- encoderNameForType t
                line $ constructor <> " y -> " <> encoder <> " y"
    where
        arrayFirstOrder a b =
            if isArray a then
                if isArray b then
                    compare a b
                else
                    LT
            else
                if isArray b then
                    GT
                else
                    compare a b

module Language.Elm
    ( renderer
    ) where

import Prelude

import Data.Array as A
import Data.Foldable (for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.String.Util (camelCase, capitalize, decapitalize, isLetterOrUnderscore, isLetterOrUnderscoreOrDigit, legalizeCharacters, startWithLetter, stringEscape)
import Data.Tuple (Tuple(..), fst)
import Doc (Doc, Namer, Renderer, blank, combineNames, forEachTopLevel_, getClasses, getOptionValue, getTopLevelNames, getTopLevels, getTypeNameForUnion, getUnions, indent, line, lookupClassName, lookupName, lookupUnionName, renderRenderItems, simpleNamer, transformPropertyNames, unionIsNotSimpleNullable, unionNameIntercalated, unlessOption, whenOption)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, isArray, nullableFromUnion, unionToList)
import Options (Option, enumOption, stringOption)
import Utils (forEnumerated_, sortByKey, sortByKeyM, mapM)

forbiddenNames :: Array String
forbiddenNames =
    [ "if", "then", "else"
    , "case", "of"
    , "let", "in"
    , "type"
    , "module", "where"
    , "import", "exposing"
    , "as"
    , "port"
    , "int", "float", "bool", "string"
    , "Jenc", "Jdec", "Jpipe"
    , "always", "identity"
    , "Array", "Dict", "Maybe", "map", "toList"
    , "makeArrayEncoder", "makeDictEncoder", "makeNullableEncoder"
    ]

listOption :: Option Boolean
listOption = enumOption "array-type" "Use Array or List" [Tuple "array" false, Tuple "list" true]

moduleOption :: Option String
moduleOption = stringOption "module" "Generated module name" "NAME" "QuickType"

renderer :: Renderer
renderer =
    { displayName: "Elm"
    , names: [ "elm" ]
    , aceMode: "elm"
    , extension: "elm"
    , doc: elmDoc
    , options:
        [ moduleOption.specification
        , listOption.specification
        ]
    , transforms:
        { nameForClass: elmNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelName: elmNamer upperNameStyle
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: elmNamer (upperNameStyle <<< combineNames)
            , nameFromTypes: elmNamer (unionNameIntercalated upperNameStyle "Or")
            }
        }
    }

decoderNameFromTypeName :: String -> String
decoderNameFromTypeName = decapitalize

encoderNameFromTypeName :: String -> String
encoderNameFromTypeName className = "encode" <> className

alsoForbiddenForTypeName :: String -> Array String
alsoForbiddenForTypeName n = [decoderNameFromTypeName n, encoderNameFromTypeName n]

elmNamer :: forall a. Ord a => (a -> String) -> Namer a
elmNamer namer thing = case _ of
    Just name -> result name
    Nothing -> result $ namer thing
    where
        result name = { name, forbid: A.cons name $ alsoForbiddenForTypeName name }

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

typeNameForTopLevelNameGiven :: String -> String
typeNameForTopLevelNameGiven = upperNameStyle

namesFromTopLevelNameGiven :: String -> Array String
namesFromTopLevelNameGiven given =
    let name = typeNameForTopLevelNameGiven given
    in A.cons name $ alsoForbiddenForTypeName name

legalize :: String -> String
legalize = legalizeCharacters isLetterOrUnderscoreOrDigit

elmNameStyle :: Boolean -> String -> String
elmNameStyle upper = legalize >>> camelCase >>> (startWithLetter isLetterOrUnderscore upper)

lowerNameStyle :: String -> String
lowerNameStyle = elmNameStyle false

upperNameStyle :: String -> String
upperNameStyle = elmNameStyle true

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

renderArrayType :: Doc String
renderArrayType = do
    useList <- getOptionValue listOption
    pure $ if useList then "List" else "Array"

elmDoc :: Doc Unit
elmDoc = do
    topLevels <- getTopLevels
    -- givenTopLevel <- typeNameForTopLevelNameGiven <$> getTopLevelNameGiven
    -- let topLevelDecoder = decoderNameFromTypeName givenTopLevel
    -- let topLevelEncoder = encoderNameFromTypeName givenTopLevel
    classes <- getClasses
    unions <- getUnions
    classNames <- mapM (\t -> lookupClassName $ fst t) classes
    unionNames <- mapM lookupUnionName unions
    topLevelNames <- M.values <$> getTopLevelNames
    let topLevelDecoders = map decoderNameFromTypeName topLevelNames
    let alsoTopLevelExports = L.concat $ map (alsoForbiddenForTypeName >>> L.fromFoldable) topLevelNames
    let exports = L.concat $ topLevelNames : alsoTopLevelExports : classNames : unionNames : L.Nil
    moduleName <- getOptionValue moduleOption
    line """-- To decode the JSON data, add this file to your project, run
--
--     elm-package install NoRedInk/elm-decode-pipeline
--
-- add these imports
--
--     import Json.Decode exposing (decodeString)"""
    line $ "--     import " <> moduleName <> " exposing (" <> (intercalate ", " topLevelDecoders) <> ")"
    line """--
-- and you're off to the races with
--"""
    forEachTopLevel_ \topLevelName topLevelType -> do
        let topLevelDecoder = decoderNameFromTypeName topLevelName
        line $ "--     decodeString " <> topLevelDecoder <> " myJsonString"
    blank
    line $ "module " <> moduleName <> " exposing"
    indent do
        forWithPrefix_ exports "( " ", " \parenOrComma name ->
            line $ parenOrComma <> name
        line ")"
    blank
    line """import Json.Decode as Jdec
import Json.Decode.Pipeline as Jpipe
import Json.Encode as Jenc
import Dict exposing (Dict, map, toList)"""
    arrayType <- renderArrayType
    whenOption listOption do
        line $ "import List exposing (map)"
    unlessOption listOption do
        line $ "import Array exposing (Array, map)"
    blank
    renderRenderItems blank (Just renderTopLevelDefinition) (typeRenderer renderTypeDefinition) (Just renderUnionDefinition)
    blank
    line "-- decoders and encoders"
    blank
    renderRenderItems blank (Just renderTopLevelFunctions) (typeRenderer renderTypeFunctions) (Just renderUnionFunctions)
    blank
    line "--- encoder helpers"
    blank
    line $ "make" <> arrayType <> "Encoder : (a -> Jenc.Value) -> " <> arrayType <> " a -> Jenc.Value"
    line $ "make" <> arrayType <> "Encoder f arr ="
    indent do
        line $ "Jenc." <> decapitalize arrayType <> " (" <> arrayType <> ".map f arr)"
    blank
    line """makeDictEncoder : (a -> Jenc.Value) -> Dict String a -> Jenc.Value
makeDictEncoder f dict =
    Jenc.object (toList (Dict.map (\k -> f) dict))

makeNullableEncoder : (a -> Jenc.Value) -> Maybe a -> Jenc.Value
makeNullableEncoder f m =
    case m of
    Just x -> f x
    Nothing -> Jenc.null"""

renderTopLevelDefinition :: String -> IRType -> Doc Unit
renderTopLevelDefinition topLevelName topLevel = do
    { rendered: topLevelRendered } <- typeStringForType topLevel
    line $ "type alias " <> topLevelName <> " = " <> topLevelRendered

renderTopLevelFunctions :: String -> IRType -> Doc Unit
renderTopLevelFunctions topLevelName topLevel = do
    let topLevelDecoder = decoderNameFromTypeName topLevelName
    let topLevelEncoder = encoderNameFromTypeName topLevelName
    { rendered: rootDecoder } <- decoderNameForType topLevel
    line $ topLevelDecoder <> " : Jdec.Decoder " <> topLevelName
    line $ topLevelDecoder <> " = " <> rootDecoder
    blank
    { rendered: rootEncoder } <- encoderNameForType topLevel
    line $ topLevelEncoder <> " : " <> topLevelName <> " -> String"
    line $ topLevelEncoder <> " r = Jenc.encode 0 (" <> rootEncoder <> " r)"

singleWord :: String -> Doc { rendered :: String, multiWord :: Boolean }
singleWord w = pure { rendered: w, multiWord: false }

multiWord :: String -> String -> Doc { rendered :: String, multiWord :: Boolean }
multiWord s1 s2 = pure { rendered: s1 <> " " <> s2, multiWord: true }

parenIfNeeded :: { rendered :: String, multiWord :: Boolean } -> String
parenIfNeeded { rendered, multiWord: false } = rendered
parenIfNeeded { rendered, multiWord: true } = "(" <> rendered <> ")"

typeStringForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
typeStringForType = case _ of
    IRNoInformation -> singleWord "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType -> singleWord "Jdec.Value"
    IRNull -> singleWord "()"
    IRInteger -> singleWord "Int"
    IRDouble -> singleWord "Float"
    IRBool -> singleWord "Bool"
    IRString -> singleWord "String"
    IRArray a -> do
        ts <- typeStringForType a
        arrayType <- renderArrayType
        multiWord arrayType $ parenIfNeeded ts
    IRClass i -> singleWord =<< lookupClassName i
    IRMap t -> do
        ts <- typeStringForType t
        multiWord "Dict String" $ parenIfNeeded ts
    IRUnion u ->
        case nullableFromUnion u of
        Just x -> do
            ts <- typeStringForType x
            multiWord "Maybe" $ parenIfNeeded ts
        Nothing -> do
            singleWord =<< lookupUnionName u

unionConstructorName :: String -> IRType -> Doc String
unionConstructorName unionName t = do
    typeName <- upperNameStyle <$> getTypeNameForUnion t
    pure $ typeName <> "In" <> unionName

decoderNameForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
decoderNameForType = case _ of
    IRNoInformation -> singleWord "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType -> singleWord "Jdec.value"
    IRNull -> multiWord "Jdec.null" "()"
    IRInteger -> singleWord "Jdec.int"
    IRDouble -> singleWord "Jdec.float"
    IRBool -> singleWord "Jdec.bool"
    IRString -> singleWord "Jdec.string"
    IRArray a -> do
        dn <- decoderNameForType a
        arrayType <- renderArrayType
        multiWord ("Jdec." <> decapitalize arrayType) $ parenIfNeeded dn
    IRClass i -> singleWord =<< decoderNameFromTypeName <$> lookupClassName i
    IRMap t -> do
        dn <- decoderNameForType t
        multiWord "Jdec.dict" $ parenIfNeeded dn
    IRUnion u ->
        case nullableFromUnion u of
        Just t -> do
            dn <- decoderNameForType t
            multiWord "Jdec.nullable" $ parenIfNeeded dn
        Nothing -> do
            singleWord =<< decoderNameFromTypeName <$> lookupUnionName u

encoderNameForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
encoderNameForType = case _ of
    IRNoInformation -> singleWord "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType -> singleWord "identity"
    IRNull -> multiWord "always" "Jenc.null"
    IRInteger -> singleWord "Jenc.int"
    IRDouble -> singleWord "Jenc.float"
    IRBool -> singleWord "Jenc.bool"
    IRString -> singleWord "Jenc.string"
    IRArray a -> do
        rendered <- encoderNameForType a
        arrayType <- renderArrayType
        multiWord ("make" <> arrayType <> "Encoder") $ parenIfNeeded rendered
    IRClass i -> singleWord =<< encoderNameFromTypeName <$> lookupClassName i
    IRMap t -> do
        rendered <- encoderNameForType t
        multiWord "makeDictEncoder" $ parenIfNeeded rendered
    IRUnion u ->
        case nullableFromUnion u of
        Just t -> do
            rendered <- encoderNameForType t
            multiWord "makeNullableEncoder" $ parenIfNeeded rendered
        Nothing ->
            singleWord =<< encoderNameFromTypeName <$> lookupUnionName u

forWithPrefix_ :: forall a b p m. Applicative m => List a -> p -> p -> (p -> a -> m b) -> m Unit
forWithPrefix_ l firstPrefix restPrefix f =
    forEnumerated_ l (\i -> f $ if i == 0 then firstPrefix else restPrefix)

renderTypeDefinition :: String -> Map String String -> List (Tuple String IRType) -> Doc Unit
renderTypeDefinition className propertyNames propsList = do
    line $ "type alias " <> className <> " ="
    indent do
        forWithPrefix_ propsList "{ " ", " \braceOrComma (Tuple pname ptype) -> do
            let propName = lookupName pname propertyNames
            { rendered } <- typeStringForType ptype
            line $ braceOrComma <> propName <> " : " <> rendered
        when (propsList == L.Nil) do
            line "{"
        line "}"

renderTypeFunctions :: String -> Map String String -> List (Tuple String IRType) -> Doc Unit
renderTypeFunctions className propertyNames propsList = do
    let decoderName = decoderNameFromTypeName className
    line $ decoderName <> " : Jdec.Decoder " <> className
    line $ decoderName <> " ="
    indent do
        line $ "Jpipe.decode " <> className
        for_ propsList \(Tuple pname ptype) -> do
            indent do
                propDecoder <- decoderNameForType ptype
                let { reqOrOpt, fallback } = requiredOrOptional ptype
                line $ "|> " <> reqOrOpt <> " \"" <> stringEscape pname <> "\" " <> (parenIfNeeded propDecoder) <> fallback
    blank
    let encoderName = encoderNameFromTypeName className
    line $ encoderName <> " : " <> className <> " -> Jenc.Value"
    line $ encoderName <> " x ="
    indent do
        line "Jenc.object"
        indent do
            forWithPrefix_ propsList "[ " ", " \bracketOrComma (Tuple pname ptype) -> do
                let propName = lookupName pname propertyNames
                { rendered: propEncoder } <- encoderNameForType ptype
                line $ bracketOrComma <> "(\"" <> stringEscape pname <> "\", " <> propEncoder <> " x." <> propName <> ")"
            when (propsList == L.Nil) do
                line "["
            line "]"
    where
        requiredOrOptional :: IRType -> { reqOrOpt :: String, fallback :: String }
        requiredOrOptional = case _ of
            IRNull -> optional " ()"
            IRUnion u ->
                if not $ unionIsNotSimpleNullable u then
                    optional " Nothing"
                else
                    required
            _ -> required
        required =
            { reqOrOpt: "Jpipe.required", fallback: "" }
        optional fallback =
            { reqOrOpt: "Jpipe.optional", fallback }

typeRenderer :: (String -> Map String String -> List (Tuple String IRType) -> Doc Unit) -> String -> Map String IRType -> Doc Unit
typeRenderer renderer' className properties = do
    let propertyNames = transformPropertyNames (simpleNamer lowerNameStyle) (\n -> "other" <> capitalize n) forbiddenNames properties
    let propsList = M.toUnfoldable properties # sortByKey (\t -> lookupName (fst t) propertyNames)
    renderer' className propertyNames propsList

renderUnionDefinition :: String -> IRUnionRep -> Doc Unit
renderUnionDefinition unionName unionRep = do
    fields <- unionToList unionRep # sortByKeyM (unionConstructorName unionName)
    line $ "type " <> unionName
    forWithPrefix_ fields "=" "|" \equalsOrPipe t -> do
        indent do
            constructor <- unionConstructorName unionName t
            when (t == IRNull) do
                line $ equalsOrPipe <> " " <> constructor
            unless (t == IRNull) do
                ts <- typeStringForType t
                line $ equalsOrPipe <> " " <> constructor <> " " <> (parenIfNeeded ts)

renderUnionFunctions :: String -> IRUnionRep -> Doc Unit
renderUnionFunctions unionName unionRep = do
    let decoderName = decoderNameFromTypeName unionName
    line $ decoderName <> " : Jdec.Decoder " <> unionName
    line $ decoderName <> " ="
    indent do
        let decFields = L.sortBy arrayFirstOrder $ unionToList unionRep
        line "Jdec.oneOf"
        indent do
            forWithPrefix_ decFields "[" "," \bracketOrComma t -> do
                constructor <- unionConstructorName unionName t
                when (t == IRNull) do
                    line $ bracketOrComma <> " Jdec.null " <> constructor
                unless (t == IRNull) do
                    decoder <- decoderNameForType t
                    line $ bracketOrComma <> " Jdec.map " <> constructor <> " " <> parenIfNeeded decoder
            line "]"
    blank
    let encoderName = encoderNameFromTypeName unionName
    line $ encoderName <> " : " <> unionName <> " -> Jenc.Value"
    line $ encoderName <> " x = case x of"
    indent do
        fields <- unionToList unionRep # sortByKeyM (unionConstructorName unionName)
        for_ fields \t -> do
            constructor <- unionConstructorName unionName t
            when (t == IRNull) do
                line $ constructor <> " -> Jenc.null"
            unless (t == IRNull) do
                { rendered: encoder } <- encoderNameForType t
                line $ constructor <> " y -> " <> encoder <> " y"
    where
        arrayFirstOrder a b =
            if isArray a then
                if isArray b then
                    compare a b
                else
                    LT
            else
                if isArray b then
                    GT
                else
                    compare a b