elm-websocket (empty) → 1.0

raw patch · 20 files changed

+1395/−0 lines, 20 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, concurrent-extra, containers, directory, elm-websocket, formatting, hspec, http-types, lens, mtl, network, scotty, stm, text, time, wai, wai-middleware-static, wai-websockets, warp, websockets, wl-pprint-text

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• elm-websocket.cabal +105/−0
• example/code-generator/Main.hs +25/−0
• example/server/shared/Api.hs +47/−0
• example/server/src/Main.hs +34/−0
• src/Elm/Export.hs +11/−0
• src/Elm/Export/Common.hs +72/−0
• src/Elm/Export/Decoder.hs +170/−0
• src/Elm/Export/Encoder.hs +214/−0
• src/Elm/Export/File.hs +65/−0
• src/Elm/Export/Record.hs +132/−0
• src/Elm/Export/Type.hs +209/−0
• src/Elm/Export/WebSocketSubscriber.hs +25/−0
• src/Elm/WebSocket.hs +6/−0
• src/Elm/WebSocket/Server.hs +74/−0
• src/Elm/WebSocket/Types.hs +15/−0
• test/BroadcastSpec.hs +71/−0
• test/RequestResponseSpec.hs +87/−0
• test/Spec.hs +1/−0

@@ -0,0 +1,30 @@+Copyright Rhys Keepene (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Matt Bray nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,105 @@+name:                elm-websocket+version:             1.0+synopsis:            Generate ELM code from a Wai websocket application.+description:         Please see README.md+homepage:            http://github.com/rhyskeepence/elm-websocket+license:             BSD3+license-file:        LICENSE+author:              Rhys Keepence+maintainer:          rhyskeepence@gmail.com+copyright:           2017 Rhys Keepence+category:            Web+build-type:          Simple+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Elm.WebSocket+                     , Elm.Export+  build-depends:       base >= 4.7 && < 5+                     , aeson+                     , bytestring+                     , concurrent-extra+                     , containers+                     , directory+                     , formatting+                     , lens+                     , mtl+                     , stm+                     , text+                     , time+                     , wai+                     , wai-websockets+                     , websockets+                     , wl-pprint-text++  ghc-options:         -Wall+  default-language:    Haskell2010+  other-modules:       Elm.WebSocket.Server+                     , Elm.WebSocket.Types+                     , Elm.Export.Common+                     , Elm.Export.Decoder+                     , Elm.Export.Encoder+                     , Elm.Export.File+                     , Elm.Export.Record+                     , Elm.Export.Type+                     , Elm.Export.WebSocketSubscriber++test-suite elm-websocket-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , aeson+                     , concurrent-extra+                     , elm-websocket+                     , hspec+                     , http-types+                     , mtl+                     , network+                     , text+                     , wai+                     , websockets+                     , warp+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall+  default-language:    Haskell2010+  other-modules:       BroadcastSpec+                     , RequestResponseSpec++executable elm-websocket-example+  hs-source-dirs:      example/server/src, example/server/shared+  main-is:             Main.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall+  build-depends:       base+                     , aeson+                     , concurrent-extra+                     , elm-websocket+                     , http-types+                     , scotty+                     , text+                     , wai+                     , wai-middleware-static+                     , warp+  other-modules:       Api+  default-language:    Haskell2010++executable elm-websocket-code-generator+  hs-source-dirs:      example/code-generator, example/server/shared+  main-is:             Main.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall+  build-depends:       base+                     , aeson+                     , concurrent-extra+                     , elm-websocket+                     , http-types+                     , scotty+                     , text+                     , wai+                     , wai-middleware-static+                     , warp+  other-modules:       Api+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/rhyskeepence/elm-websocket

@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Api+import Data.Proxy+import Elm.Export++spec :: Spec+spec =+  moduleSpec ["Api"] $ do+    renderType (Proxy :: Proxy TaskStatus)+    renderType (Proxy :: Proxy Task)+    renderType (Proxy :: Proxy Request)+    renderType (Proxy :: Proxy Response)+    renderEncoder (Proxy :: Proxy TaskStatus)+    renderEncoder (Proxy :: Proxy Task)+    renderEncoder (Proxy :: Proxy Request)+    renderDecoder (Proxy :: Proxy TaskStatus)+    renderDecoder (Proxy :: Proxy Task)+    renderDecoder (Proxy :: Proxy Response)+    renderSubscriber++main :: IO ()+main = specsToDir [spec] "client/src"

@@ -0,0 +1,47 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}++module Api where++import Elm.Export+import           GHC.Generics                  (Generic)+import           Data.Aeson                    (FromJSON, ToJSON)+import Data.Text+++data TaskStatus+  = Ready+  | InPlay+  | Done+  deriving (Eq, Show, Generic, ElmType)++instance ToJSON TaskStatus++instance FromJSON TaskStatus++data Task+  = Task+  { id :: Int+  , name :: Text+  , description :: Text+  , status :: TaskStatus+  } deriving (Eq, Show, Generic, ElmType)++instance ToJSON Task++instance FromJSON Task+++data Request+  = CreateTaskRequest Text Text+  | LoadAllTasksRequest+  deriving (Eq, Show, Generic, ElmType)++instance FromJSON Request++newtype Response+  = Response+  { tasks :: [Task]+  } deriving (Eq, Show, Generic, ElmType)++instance ToJSON Response

@@ -0,0 +1,34 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import           Api+import           Control.Concurrent.MVar       as MVar+import           Elm.WebSocket                 as WS+import qualified Network.Wai.Handler.Warp      as Warp+import           Network.Wai.Middleware.Static+import           Web.Scotty++main :: IO ()+main = do+  tasks <- MVar.newMVar []+  broadcaster <- WS.newBroadcaster+  httpApplication <- scottyApp httpEndpoints+  Warp.run 8080 $ WS.withWebSocketBroadcaster broadcaster (webSocketService tasks broadcaster) httpApplication++webSocketService :: MVar [Task] -> Broadcaster -> WebSocketServer Request Response+webSocketService tasks broadcaster request =+  case request of+    CreateTaskRequest name description -> do+      MVar.modifyMVar_ tasks (\allTasks -> return $ allTasks ++ [Task 1 name description Ready])+      newTasks <- MVar.readMVar tasks+      WS.broadcast broadcaster $ Response newTasks+      return Nothing+    LoadAllTasksRequest -> do+      newTasks <- MVar.readMVar tasks+      return $ Just $ Response newTasks++httpEndpoints :: ScottyM ()+httpEndpoints = do+  middleware $ staticPolicy (noDots >-> addBase "assets")+  matchAny "/" $ redirect "/index.html"

@@ -0,0 +1,11 @@+module Elm.Export+  ( module X+  ) where++import Elm.Export.Common as X (Options(..), defaultOptions, require)+import Elm.Export.Decoder as X+import Elm.Export.Encoder as X+import Elm.Export.File as X+import Elm.Export.Record as X+import Elm.Export.Type as X+import Elm.Export.WebSocketSubscriber as X

@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings #-}++module Elm.Export.Common where++import Control.Monad.RWS+import Data.Set (Set)+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text.Lazy as LT+import Formatting hiding (text)+import Text.PrettyPrint.Leijen.Text hiding ((<$>), (<>))++data Options = Options+  { fieldLabelModifier :: Text -> Text+  }++defaultOptions :: Options+defaultOptions = Options {fieldLabelModifier = id}++cr :: Format r r+cr = now "\n"++mintercalate+  :: Monoid m+  => m -> [m] -> m+mintercalate _ [] = mempty+mintercalate _ [x] = x+mintercalate seperator (x:xs) = x <> seperator <> mintercalate seperator xs++pprinter :: Doc -> Text+pprinter = LT.toStrict . displayT . renderPretty 0.4 100++stext :: Data.Text.Text -> Doc+stext = text . LT.fromStrict++spaceparens :: Doc -> Doc+spaceparens doc = "(" <+> doc <+> ")"++-- | Parentheses of which the right parenthesis exists on a new line+newlineparens :: Doc -> Doc+newlineparens doc = "(" <> doc <$$> ")"++-- | An empty line, regardless of current indentation+emptyline :: Doc+emptyline = nest minBound linebreak++-- | Like <$$>, but with an empty line in between+(<$+$>) :: Doc -> Doc -> Doc+l <$+$> r = l <> emptyline <$$> r++--+type RenderM = RWS Options (Set Text -- The set of required imports+                            , [Text] -- Generated declarations+                            ) ()++{-| Add an import to the set.+-}+require :: Text -> RenderM ()+require dep = tell (S.singleton dep, [])++{-| Take the result of a RenderM computation and put it into the Writer's+declarations.+-}+collectDeclaration :: RenderM Doc -> RenderM ()+collectDeclaration =+  mapRWS ((\(defn, (), (imports, _)) -> ((), (), (imports, [pprinter defn]))))++squarebracks :: Doc -> Doc+squarebracks doc = "[" <+> doc <+> "]"++pair :: Doc -> Doc -> Doc+pair l r = spaceparens $ l <> comma <+> r

@@ -0,0 +1,170 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module Elm.Export.Decoder+  ( toElmDecoderRef+  , toElmDecoderRefWith+  , toElmDecoderSource+  , toElmDecoderSourceWith+  , renderDecoder+  ) where++import Control.Monad.RWS+import qualified Data.Text as T+import Elm.Export.Common+import Elm.Export.Type+import Text.PrettyPrint.Leijen.Text hiding ((<$>), (<>))++class HasDecoder a where+  render :: a -> RenderM Doc++class HasDecoderRef a where+  renderRef :: a -> RenderM Doc++instance HasDecoder ElmDatatype where+  render d@(ElmDatatype name constructor) = do+    fnName <- renderRef d+    ctor <- render constructor+    return $+      (fnName <+> ": Decoder" <+> stext name) <$$>+      (fnName <+> "=" <$$> indent 4 ctor)+  render (ElmPrimitive primitive) = renderRef primitive++instance HasDecoderRef ElmDatatype where+  renderRef (ElmDatatype name _) = pure $ "decode" <> stext name+  renderRef (ElmPrimitive primitive) = renderRef primitive++instance HasDecoder ElmConstructor where+  render (NamedConstructor name value) = do+    dv <- render value+    return $ "decode" <+> stext name <$$> indent 4 dv+  render (RecordConstructor name value) = do+    dv <- render value+    return $ "decode" <+> stext name <$$> indent 4 dv++  render mc@(MultipleConstructors constrs) = do+      cstrs <- mapM renderSum constrs+      pure $ constructorName <$$> indent 4+        ("|> andThen" <$$>+          indent 4 (newlineparens ("\\x ->" <$$>+            (indent 4 $ "case x of" <$$>+              (indent 4 $ foldl1 (<$+$>) cstrs <$+$>+               "_ ->" <$$> indent 4 "fail \"Constructor not matched\""+              )+            )+          ))+        )+    where+      constructorName :: Doc+      constructorName =+        if isEnumeration mc then "string" else "field \"tag\" string"++-- | required "contents"+requiredContents :: Doc+requiredContents = "required" <+> dquotes "contents"++-- | "<name>" -> decode <name>+renderSumCondition :: T.Text -> Doc -> RenderM Doc+renderSumCondition name contents =+  pure $ dquotes (stext name) <+> "->" <$$>+    indent 4+      ("decode" <+> stext name <$$> indent 4 contents)++-- | Render a sum type constructor in context of a data type with multiple+-- constructors.+renderSum :: ElmConstructor -> RenderM Doc+renderSum (NamedConstructor name ElmEmpty) = renderSumCondition name mempty+renderSum (NamedConstructor name v@(Values _ _)) = do+  (_, val) <- renderConstructorArgs 0 v+  renderSumCondition name val+renderSum (NamedConstructor name value) = do+  val <- render value+  renderSumCondition name $ "|>" <+> requiredContents <+> val+renderSum (RecordConstructor name value) = do+  val <- render value+  renderSumCondition name val+renderSum (MultipleConstructors constrs) =+  foldl1 (<$+$>) <$> mapM renderSum constrs++-- | Render the decoding of a constructor's arguments. Note the constructor must+-- be from a data type with multiple constructors and that it has multiple+-- constructors itself.+renderConstructorArgs :: Int -> ElmValue -> RenderM (Int, Doc)+renderConstructorArgs i (Values l r) = do+  (iL, rndrL) <- renderConstructorArgs i l+  (iR, rndrR) <- renderConstructorArgs (iL + 1) r+  pure (iR, rndrL <$$> rndrR)+renderConstructorArgs i val = do+  rndrVal <- render val+  let index = parens $ "index" <+> int i <+> rndrVal+  pure (i, "|>" <+> requiredContents <+> index)++instance HasDecoder ElmValue where+  render (ElmRef name) = pure $ "decode" <> stext name+  render (ElmPrimitiveRef primitive) = renderRef primitive+  render (Values x y) = do+    dx <- render x+    dy <- render y+    return $ dx <$$> dy+  render (ElmField name value) = do+    fieldModifier <- asks fieldLabelModifier+    dv <- render value+    return $ "|> required" <+> dquotes (stext (fieldModifier name)) <+> dv+  render _ = error "instance HasDecoder ElmValue: should not happen"++instance HasDecoderRef ElmPrimitive where+  renderRef (EList (ElmPrimitive EChar)) = pure "string"+  renderRef (EList datatype) = do+    dt <- renderRef datatype+    return . parens $ "list" <+> dt+  renderRef (EDict key value) = do+    require "Dict"+    d <- renderRef (EList (ElmPrimitive (ETuple2 (ElmPrimitive key) value)))+    return . parens $ "map Dict.fromList" <+> d+  renderRef (EMaybe datatype) = do+    dt <- renderRef datatype+    return . parens $ "nullable" <+> dt+  renderRef (ETuple2 x y) = do+    dx <- renderRef x+    dy <- renderRef y+    return . parens $+      "map2 (,)" <+> parens ("index 0" <+> dx) <+> parens ("index 1" <+> dy)+  renderRef EUnit = pure $ parens "succeed ()"+  renderRef EDate = pure "decodeDate"+  renderRef EInt = pure "int"+  renderRef EBool = pure "bool"+  renderRef EChar = pure "char"+  renderRef EFloat = pure "float"+  renderRef EString = pure "string"++toElmDecoderRefWith+  :: ElmType a+  => Options -> a -> T.Text+toElmDecoderRefWith options x =+  pprinter . fst $ evalRWS (renderRef (toElmType x)) options ()++toElmDecoderRef+  :: ElmType a+  => a -> T.Text+toElmDecoderRef = toElmDecoderRefWith defaultOptions++toElmDecoderSourceWith+  :: ElmType a+  => Options -> a -> T.Text+toElmDecoderSourceWith options x =+  pprinter . fst $ evalRWS (render (toElmType x)) options ()++toElmDecoderSource+  :: ElmType a+  => a -> T.Text+toElmDecoderSource = toElmDecoderSourceWith defaultOptions++renderDecoder+  :: ElmType a+  => a -> RenderM ()+renderDecoder x = do+  require "Json.Decode exposing (..)"+  require "Json.Decode.Pipeline exposing (..)"+  collectDeclaration . render . toElmType $ x

@@ -0,0 +1,214 @@+{-# LANGUAGE OverloadedStrings #-}++module Elm.Export.Encoder+  ( toElmEncoderRef+  , toElmEncoderRefWith+  , toElmEncoderSource+  , toElmEncoderSourceWith+  , renderEncoder+  ) where++import Control.Monad.RWS+import qualified Data.Text as T+import Elm.Export.Common+import Elm.Export.Type+import Text.PrettyPrint.Leijen.Text hiding ((<$>), (<>))++class HasEncoder a where+  render :: a -> RenderM Doc++class HasEncoderRef a where+  renderRef :: a -> RenderM Doc++instance HasEncoder ElmDatatype where+  render d@(ElmDatatype name constructor) = do+    fnName <- renderRef d+    ctor <- render constructor+    return $+      (fnName <+> ":" <+> stext name <+> "->" <+> "Json.Encode.Value") <$$>+      (fnName <+> "x =" <$$> indent 4 ctor)+  render (ElmPrimitive primitive) = renderRef primitive++instance HasEncoderRef ElmDatatype where+  renderRef (ElmDatatype name _) = pure $ "encode" <> stext name+  renderRef (ElmPrimitive primitive) = renderRef primitive++instance HasEncoder ElmConstructor where+  -- Single constructor, no values: empty array+  render (NamedConstructor _name ElmEmpty) =+    return $ "Json.Encode.list []"++  -- Single constructor, multiple values: create array with values+  render (NamedConstructor name value@(Values _ _)) = do+    let ps = constructorParameters 0 value++    (dv, _) <- renderVariable ps value++    let cs = stext name <+> foldl1 (<+>) ps <+> "->"+    return . nest 4 $ "case x of" <$$>+      (nest 4 $ cs <$$> nest 4 ("Json.Encode.list" <$$> "[" <+> dv <$$> "]"))++  -- Single constructor, one value: skip constructor and render just the value+  render (NamedConstructor _name val) =+    render val+++  render (RecordConstructor _ value) = do+    dv <- render value+    return . nest 4 $ "Json.Encode.object" <$$> "[" <+> dv <$$> "]"++  render mc@(MultipleConstructors constrs) = do+    let rndr = if isEnumeration mc then renderEnumeration else renderSum+    dc <- mapM rndr constrs+    return . nest 4 $ "case x of" <$$> foldl1 (<$+$>) dc++jsonEncodeObject :: Doc -> Doc -> Doc -> Doc+jsonEncodeObject constructor tag contents =+  nest 4 $ constructor <$$>+    nest 4 ("Json.Encode.object" <$$> "[" <+> tag <$$>+      contents <$$>+    "]")++renderSum :: ElmConstructor -> RenderM Doc+renderSum c@(NamedConstructor name ElmEmpty) = do+  dc <- render c+  let cs = stext name <+> "->"+  let tag = pair (dquotes "tag") ("Json.Encode.string" <+> dquotes (stext name))+  let ct = comma <+> pair (dquotes "contents") dc++  return $ jsonEncodeObject cs tag ct++renderSum (NamedConstructor name value) = do+  let ps = constructorParameters 0 value++  (dc, _) <- renderVariable ps value+  let dc' = if length ps > 1 then "Json.Encode.list" <+> squarebracks dc else dc+  let cs = stext name <+> foldl1 (<+>) ps <+> "->"+  let tag = pair (dquotes "tag") ("Json.Encode.string" <+> dquotes (stext name))+  let ct = comma <+> pair (dquotes "contents") dc'++  return $ jsonEncodeObject cs tag ct++renderSum (RecordConstructor name value) = do+  dv <- render value+  let cs = stext name <+> "->"+  let tag = pair (dquotes "tag") (dquotes $ stext name)+  let ct = comma <+> dv+  return $ jsonEncodeObject cs tag ct++renderSum (MultipleConstructors constrs) = do+  dc <- mapM renderSum constrs+  return $ foldl1 (<$+$>) dc+++renderEnumeration :: ElmConstructor -> RenderM Doc+renderEnumeration (NamedConstructor name _) =+  return . nest 4 $ stext name <+> "->" <$$>+      "Json.Encode.string" <+> dquotes (stext name)+renderEnumeration (MultipleConstructors constrs) = do+  dc <- mapM renderEnumeration constrs+  return $ foldl1 (<$+$>) dc+renderEnumeration c = render c+++instance HasEncoder ElmValue where+  render (ElmField name value) = do+    fieldModifier <- asks fieldLabelModifier+    valueBody <- render value+    return . spaceparens $+      dquotes (stext (fieldModifier name)) <> comma <+>+      (valueBody <+> "x." <> stext name)+  render (ElmPrimitiveRef primitive) = renderRef primitive+  render (ElmRef name) = pure $ "encode" <> stext name+  render (Values x y) = do+    dx <- render x+    dy <- render y+    return $ dx <$$> comma <+> dy+  render _ = error "HasEncoderRef ElmValue: should not happen"++instance HasEncoderRef ElmPrimitive where+  renderRef EDate = pure $ parens "Json.Encode.string << toString"+  renderRef EUnit = pure "Json.Encode.null"+  renderRef EInt = pure "Json.Encode.int"+  renderRef EChar = pure "Json.Encode.char"+  renderRef EBool = pure "Json.Encode.bool"+  renderRef EFloat = pure "Json.Encode.float"+  renderRef EString = pure "Json.Encode.string"+  renderRef (EList (ElmPrimitive EChar)) = pure "Json.Encode.string"+  renderRef (EList datatype) = do+    dd <- renderRef datatype+    return . parens $ "Json.Encode.list << List.map" <+> dd+  renderRef (EMaybe datatype) = do+    dd <- renderRef datatype+    return . parens $ "Maybe.withDefault Json.Encode.null << Maybe.map" <+> dd+  renderRef (ETuple2 x y) = do+    dx <- renderRef x+    dy <- renderRef y+    require "Exts.Json.Encode"+    return . parens $ "Exts.Json.Encode.tuple2" <+> dx <+> dy+  renderRef (EDict k v) = do+    dk <- renderRef k+    dv <- renderRef v+    require "Exts.Json.Encode"+    return . parens $ "Exts.Json.Encode.dict" <+> dk <+> dv++toElmEncoderRefWith+  :: ElmType a+  => Options -> a -> T.Text+toElmEncoderRefWith options x =+  pprinter . fst $ evalRWS (renderRef (toElmType x)) options ()++toElmEncoderRef+  :: ElmType a+  => a -> T.Text+toElmEncoderRef = toElmEncoderRefWith defaultOptions++toElmEncoderSourceWith+  :: ElmType a+  => Options -> a -> T.Text+toElmEncoderSourceWith options x =+  pprinter . fst $ evalRWS (render (toElmType x)) options ()++toElmEncoderSource+  :: ElmType a+  => a -> T.Text+toElmEncoderSource = toElmEncoderSourceWith defaultOptions++renderEncoder+  :: ElmType a+  => a -> RenderM ()+renderEncoder x = do+  require "Json.Encode"+  collectDeclaration . render . toElmType $ x++-- | Variable names for the members of constructors+-- Used in pattern matches+constructorParameters :: Int -> ElmValue -> [Doc]+constructorParameters _ ElmEmpty = [ empty ]+constructorParameters i (Values l r) =+    left ++ right+  where+    left = constructorParameters i l+    right = constructorParameters (length left + i) r+constructorParameters i _ = [ "y" <> int i ]+++-- | Encode variables following the recipe of an ElmValue+renderVariable :: [Doc] -> ElmValue -> RenderM (Doc, [Doc])+renderVariable (d : ds) v@(ElmRef {}) = do+  v' <- render v+  return (v' <+> d, ds)+renderVariable ds ElmEmpty = return (empty, ds)+renderVariable (_ : ds) (ElmPrimitiveRef EUnit) =+  return ("Json.Encode.null", ds)+renderVariable (d : ds) (ElmPrimitiveRef ref) = do+  r <- renderRef ref+  return (r <+> d, ds)+renderVariable ds (Values l r) = do+  (left, dsl) <- renderVariable ds l+  (right, dsr) <- renderVariable dsl r+  return (left <> comma <+> right, dsr)+renderVariable ds f@(ElmField _ _) = do+  f' <- render f+  return (f', ds)+renderVariable [] _ = error "Amount of variables does not match variables"

@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}++module Elm.Export.File+  ( Spec(..)+  , specsToDir+  , moduleSpec+  , moduleSpecWith+  ) where++import Control.Monad.RWS+import Data.List+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Elm.Export.Common+import Formatting as F+import System.Directory++makePath :: [Text] -> Text+makePath = T.intercalate "/"++data Spec = Spec+  { namespace :: [Text]+  , declarations :: [Text]+  } deriving (Eq, Show)++pathForSpec :: FilePath -> Spec -> [Text]+pathForSpec rootDir spec = T.pack rootDir : namespace spec++ensureDirectory :: FilePath -> Spec -> IO ()+ensureDirectory rootDir spec =+  let dir = makePath . Data.List.init $ pathForSpec rootDir spec+  in createDirectoryIfMissing True (T.unpack dir)++specToFile :: FilePath -> Spec -> IO ()+specToFile rootDir spec =+  let path = pathForSpec rootDir spec+      file = makePath path <> ".elm"+      namespaceText = T.intercalate "." (namespace spec)+      body =+        T.intercalate+          "\n\n"+          (sformat ("module " % F.stext % " exposing (..)") namespaceText :+           declarations spec)+  in do fprint ("Writing: " % F.stext % "\n") file+        T.writeFile (T.unpack file) body++specsToDir :: [Spec] -> FilePath -> IO ()+specsToDir specs rootDir = mapM_ processSpec specs+  where+    processSpec = ensureDirectory rootDir >> specToFile rootDir++moduleSpecWith :: Options -> [Text] -> RenderM () -> Spec+moduleSpecWith options ns m =+  let ((), (imports, defns)) = execRWS m options ()+  in Spec+     { namespace = ns+     , declarations =+         (T.intercalate "\n" . fmap ("import " <>) . S.toAscList $ imports) :+         defns+     }++moduleSpec :: [Text] -> RenderM () -> Spec+moduleSpec = moduleSpecWith defaultOptions

@@ -0,0 +1,132 @@+{-# LANGUAGE OverloadedStrings #-}++module Elm.Export.Record+  ( toElmTypeRef+  , toElmTypeRefWith+  , toElmTypeSource+  , toElmTypeSourceWith+  , renderType+  ) where++import Control.Monad.RWS+import qualified Data.Text as T+import Elm.Export.Common+import Elm.Export.Type+import Text.PrettyPrint.Leijen.Text hiding ((<$>), (<>))++class HasType a where+  render :: a -> RenderM Doc++class HasRecordType a where+  renderRecord :: a -> RenderM Doc++class HasTypeRef a where+  renderRef :: a -> RenderM Doc++instance HasType ElmDatatype where+  render d@(ElmDatatype _ constructor@(RecordConstructor _ _)) = do+    name <- renderRef d+    ctor <- render constructor+    return . nest 4 $ "type alias" <+> name <+> "=" <$$> ctor+  render d@(ElmDatatype _ constructor) = do+    name <- renderRef d+    ctor <- render constructor+    return . nest 4 $ "type" <+> name <$$> "=" <+> ctor+  render (ElmPrimitive primitive) = renderRef primitive++instance HasTypeRef ElmDatatype where+  renderRef (ElmDatatype typeName _) = pure (stext typeName)+  renderRef (ElmPrimitive primitive) = renderRef primitive++instance HasType ElmConstructor where+  render (RecordConstructor _ value) = do+    dv <- renderRecord value+    return $ "{" <+> dv <$$> "}"+  render (NamedConstructor constructorName value) = do+    dv <- render value+    return $ stext constructorName <+> dv+  render (MultipleConstructors constructors) =+    mintercalate (line <> "|" <> space) <$> sequence (render <$> constructors)++instance HasType ElmValue where+  render (ElmRef name) = pure (stext name)+  render (ElmPrimitiveRef primitive) = elmRefParens primitive <$> renderRef primitive+  render ElmEmpty = pure (text "")+  render (Values x y) = do+    dx <- render x+    dy <- render y+    return $ dx <+> dy+  render (ElmField name value) = do+    fieldModifier <- asks fieldLabelModifier+    dv <- renderRecord value+    return $ stext (fieldModifier name) <+> ":" <+> dv++instance HasRecordType ElmValue where+  renderRecord (ElmPrimitiveRef primitive) = renderRef primitive+  renderRecord (Values x y) = do+    dx <- renderRecord x+    dy <- renderRecord y+    return $ dx <$$> comma <+> dy+  renderRecord value = render value++instance HasTypeRef ElmPrimitive where+  renderRef (EList (ElmPrimitive EChar)) = renderRef EString+  renderRef (EList datatype) = do+    dt <- renderRef datatype+    return $ "List" <+> parens dt+  renderRef (ETuple2 x y) = do+    dx <- renderRef x+    dy <- renderRef y+    return . parens $ dx <> comma <+> dy+  renderRef (EMaybe datatype) = do+    dt <- renderRef datatype+    return $ "Maybe" <+> parens dt+  renderRef (EDict k v) = do+    require "Dict"+    dk <- renderRef k+    dv <- renderRef v+    return $ "Dict" <+> parens dk <+> parens dv+  renderRef EInt = pure "Int"+  renderRef EDate = do+    require "Date"+    pure "Date"+  renderRef EBool = pure "Bool"+  renderRef EChar = pure "Char"+  renderRef EString = pure "String"+  renderRef EUnit = pure "()"+  renderRef EFloat = pure "Float"++-- | Puts parentheses around the doc of an elm ref if it contains spaces.+elmRefParens :: ElmPrimitive -> Doc -> Doc+elmRefParens (EList (ElmPrimitive EChar)) = id+elmRefParens (EList _) = parens+elmRefParens (EMaybe _) = parens+elmRefParens (EDict _ _) = parens+elmRefParens _ = id++toElmTypeRefWith+  :: ElmType a+  => Options -> a -> T.Text+toElmTypeRefWith options x =+  pprinter . fst $ evalRWS (renderRef (toElmType x)) options ()++toElmTypeRef+  :: ElmType a+  => a -> T.Text+toElmTypeRef = toElmTypeRefWith defaultOptions++toElmTypeSourceWith+  :: ElmType a+  => Options -> a -> T.Text+toElmTypeSourceWith options x =+  pprinter . fst $ evalRWS (render (toElmType x)) options ()++toElmTypeSource+  :: ElmType a+  => a -> T.Text+toElmTypeSource = toElmTypeSourceWith defaultOptions++renderType+  :: ElmType a+  => a -> RenderM ()+renderType = collectDeclaration . render . toElmType

@@ -0,0 +1,209 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Elm.Export.Type where++import Data.Int (Int16, Int32, Int64, Int8)+import Data.IntMap+import Data.Map+import Data.Proxy+import Data.Text hiding (all)+import Data.Time+import GHC.Generics+import Prelude++data ElmDatatype+  = ElmDatatype Text+                ElmConstructor+  | ElmPrimitive ElmPrimitive+  deriving (Show, Eq)++data ElmPrimitive+  = EInt+  | EBool+  | EChar+  | EDate+  | EFloat+  | EString+  | EUnit+  | EList ElmDatatype+  | EMaybe ElmDatatype+  | ETuple2 ElmDatatype+            ElmDatatype+  | EDict ElmPrimitive+          ElmDatatype+  deriving (Show, Eq)++data ElmConstructor+  = NamedConstructor Text+                     ElmValue+  | RecordConstructor Text+                      ElmValue+  | MultipleConstructors [ElmConstructor]+  deriving (Show, Eq)++data ElmValue+  = ElmRef Text+  | ElmEmpty+  | ElmPrimitiveRef ElmPrimitive+  | Values ElmValue+           ElmValue+  | ElmField Text+             ElmValue+  deriving (Show, Eq)++------------------------------------------------------------+class ElmType a where+  toElmType :: a -> ElmDatatype+  toElmType = genericToElmDatatype . from+  default toElmType :: (Generic a, GenericElmDatatype (Rep a)) =>+    a -> ElmDatatype++------------------------------------------------------------+class GenericElmDatatype f where+  genericToElmDatatype :: f a -> ElmDatatype++instance (Datatype d, GenericElmConstructor f) =>+         GenericElmDatatype (D1 d f) where+  genericToElmDatatype datatype =+    ElmDatatype+      (pack (datatypeName datatype))+      (genericToElmConstructor (unM1 datatype))++-- ------------------------------------------------------------+class GenericElmConstructor f where+  genericToElmConstructor :: f a -> ElmConstructor++instance (Constructor c, GenericElmValue f) =>+         GenericElmConstructor (C1 c f) where+  genericToElmConstructor constructor =+    if conIsRecord constructor+      then RecordConstructor name (genericToElmValue (unM1 constructor))+      else NamedConstructor name (genericToElmValue (unM1 constructor))+    where+      name = pack $ conName constructor++instance (GenericElmConstructor f, GenericElmConstructor g) =>+         GenericElmConstructor (f :+: g) where+  genericToElmConstructor _ =+    MultipleConstructors+      [ genericToElmConstructor (undefined :: f p)+      , genericToElmConstructor (undefined :: g p)+      ]++------------------------------------------------------------+class GenericElmValue f where+  genericToElmValue :: f a -> ElmValue++instance (Selector s, GenericElmValue a) =>+         GenericElmValue (S1 s a) where+  genericToElmValue selector =+    case selName selector of+      "" -> genericToElmValue (undefined :: a p)+      name -> ElmField (pack name) (genericToElmValue (undefined :: a p))++instance (GenericElmValue f, GenericElmValue g) =>+         GenericElmValue (f :*: g) where+  genericToElmValue _ =+    Values+      (genericToElmValue (undefined :: f p))+      (genericToElmValue (undefined :: g p))++instance GenericElmValue U1 where+  genericToElmValue _ = ElmEmpty++instance ElmType a =>+         GenericElmValue (Rec0 a) where+  genericToElmValue _ =+    case toElmType (Proxy :: Proxy a) of+      ElmPrimitive primitive -> ElmPrimitiveRef primitive+      ElmDatatype name _ -> ElmRef name++instance ElmType a =>+         ElmType [a] where+  toElmType _ = ElmPrimitive (EList (toElmType (Proxy :: Proxy a)))++instance ElmType a =>+         ElmType (Maybe a) where+  toElmType _ = ElmPrimitive (EMaybe (toElmType (Proxy :: Proxy a)))++instance ElmType () where+  toElmType _ = ElmPrimitive EUnit++instance ElmType Text where+  toElmType _ = ElmPrimitive EString++instance ElmType Day where+  toElmType _ = ElmPrimitive EDate++instance ElmType UTCTime where+  toElmType _ = ElmPrimitive EDate++instance ElmType Float where+  toElmType _ = ElmPrimitive EFloat++instance ElmType Double where+  toElmType _ = ElmPrimitive EFloat++instance ElmType Int8 where+  toElmType _ = ElmPrimitive EInt++instance ElmType Int16 where+  toElmType _ = ElmPrimitive EInt++instance ElmType Int32 where+  toElmType _ = ElmPrimitive EInt++instance ElmType Int64 where+  toElmType _ = ElmPrimitive EInt++instance (ElmType a, ElmType b) =>+         ElmType (a, b) where+  toElmType _ =+    ElmPrimitive $+    ETuple2 (toElmType (Proxy :: Proxy a)) (toElmType (Proxy :: Proxy b))++instance (ElmType a) =>+         ElmType (Proxy a) where+  toElmType _ = toElmType (undefined :: a)++instance (HasElmComparable k, ElmType v) =>+         ElmType (Map k v) where+  toElmType _ =+    ElmPrimitive $+    EDict (toElmComparable (undefined :: k)) (toElmType (Proxy :: Proxy v))++instance (ElmType v) =>+         ElmType (IntMap v) where+  toElmType _ = ElmPrimitive $ EDict EInt (toElmType (Proxy :: Proxy v))++class HasElmComparable a where+  toElmComparable :: a -> ElmPrimitive++instance HasElmComparable String where+  toElmComparable _ = EString++instance HasElmComparable Text where+  toElmComparable _ = EString++instance ElmType Int where+  toElmType _ = ElmPrimitive EInt++instance ElmType Char where+  toElmType _ = ElmPrimitive EChar++instance ElmType Bool where+  toElmType _ = ElmPrimitive EBool++-- | Whether a set of constructors is an enumeration, i.e. whether they lack+-- values. data A = A | B | C would be simple data A = A Int | B | C would not+-- be simple.+isEnumeration :: ElmConstructor -> Bool+isEnumeration (NamedConstructor _ ElmEmpty) = True+isEnumeration (MultipleConstructors cs) = all isEnumeration cs+isEnumeration _ = False

@@ -0,0 +1,25 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators     #-}++module Elm.Export.WebSocketSubscriber+  ( renderSubscriber+  ) where++import           Elm.Export.Common+import           Text.PrettyPrint.Leijen.Text++renderSubscriber :: RenderM ()+renderSubscriber = do+  require "WebSocket"+  require "Json.Decode exposing (Decoder, decodeString)"+  require "Result exposing (Result(..))"+  collectDeclaration . return $+    "listen : String -> Decoder a -> (Result String a -> msg) -> Sub msg" <$$>+    "listen host decoder tagger = " <$$>+    "    WebSocket.listen (\"ws://\" ++ host) (\\str -> decodeString decoder str |> tagger)" <$$>+    emptyline <$$>+    "send : String -> (a -> Json.Encode.Value) -> a -> Cmd msg" <$$>+    "send host encoder value =" <$$>+    "    WebSocket.send (\"ws://\" ++ host) (Json.Encode.encode 0 (encoder value))"

@@ -0,0 +1,6 @@+module Elm.WebSocket+  ( module Exports+  ) where++import           Elm.WebSocket.Server as Exports+import           Elm.WebSocket.Types  as Exports

@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings #-}++module Elm.WebSocket.Server+  ( withWebSocketBroadcaster+  , newBroadcaster+  , broadcast+  ) where++import Elm.WebSocket.Types++import Control.Concurrent+import Control.Concurrent.STM.TChan+       (newBroadcastTChanIO, readTChan, dupTChan, writeTChan)++import Control.Monad (forever)+import Control.Monad.STM (atomically)+import Data.Aeson (FromJSON, ToJSON, encode, decode)+import Data.Foldable (traverse_)+import qualified Network.Wai as Wai+import qualified Network.Wai.Handler.WebSockets as WS+import qualified Network.WebSockets as WS++webSocketApp :: FromJSON a => ToJSON b => Broadcaster -> WebSocketServer a b -> WS.ServerApp+webSocketApp incomingBroadcasts server pendingConnection = do+  connection <- WS.acceptRequest pendingConnection+  WS.forkPingThread connection 30+  forkBroadcastThread connection incomingBroadcasts+  let loop = do+        WS.Text message <- WS.receiveDataMessage connection+        traverse_ (handleRequest connection server) (decode message)+        loop+  loop+++handleRequest :: FromJSON a => ToJSON b => WS.Connection -> WebSocketServer a b -> a -> IO ()+handleRequest connection server request = do+  response <- server request+  traverse_ (WS.sendTextData connection . encode) response+  return ()++forkBroadcastThread :: WS.Connection -> Broadcaster -> IO ()+forkBroadcastThread connection incomingBroadcasts = do+  _ <-+    forkIO $ do+      channel <- atomically $ dupTChan incomingBroadcasts+      forever $ do+        message <- atomically $ readTChan channel+        WS.sendTextData connection message+  return ()++{-|+  Return a Wai.Application, which hosts both a WebSocket application, defined by the WebSocketServer,+  along with a non-websocket Wai.Application.++  This function also requires a Broadcaster, which is used to broadcast WebSocket messages to connected clients.++  The WebSocket application uses JSON as a wire format, so must have a FromJSON instance defined for the Request type,+  and a ToJSON instance defined for the Response type.+-}+withWebSocketBroadcaster :: FromJSON a => ToJSON b => Broadcaster -> WebSocketServer a b -> Wai.Application -> Wai.Application+withWebSocketBroadcaster connectedClients server =+  WS.websocketsOr WS.defaultConnectionOptions $ webSocketApp connectedClients server++{-|+  Create a Broadcaster, used to send messages to all connected clients.+-}+newBroadcaster :: IO Broadcaster+newBroadcaster = newBroadcastTChanIO++{-|+  Broadcast a message to all connected clients.+-}+broadcast :: ToJSON a => Broadcaster -> a -> IO ()+broadcast broadcaster message = atomically $ writeTChan broadcaster $ encode message

@@ -0,0 +1,15 @@+module Elm.WebSocket.Types where++import           Control.Concurrent.STM.TChan (TChan)+import           Data.ByteString.Lazy++{-|+  Broadcaster to send a message to all clients connected to the WebSocketServer.+-}+type Broadcaster = TChan ByteString++{-|+  A WebSocketServer handles incoming WebSocket requests of type a, and+  may choose to respond with a response of type b.+-}+type WebSocketServer a b = a -> IO (Maybe b)

@@ -0,0 +1,71 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}++module BroadcastSpec where++import           Elm.WebSocket+import           Test.Hspec++import           Control.Concurrent (forkIO)+import qualified Control.Concurrent.Broadcast as B+import qualified Control.Concurrent.Event     as E+import           Control.Monad                (forever)+import           Data.Aeson                   (ToJSON, FromJSON)+import           Data.Text (Text)+import           GHC.Generics                 (Generic)+import           Network.HTTP.Types+import           Network.Wai+import           Network.Wai.Handler.Warp     (testWithApplication)+import qualified Network.WebSockets           as WS++newtype Message = Message+  { hello :: String+  } deriving (Eq, Show, Generic)++instance ToJSON Message+instance FromJSON Message++type ReceivedMessage = B.Broadcast Text++type TestState = (Broadcaster, ReceivedMessage)++spec :: Spec+spec = broadcastSpec++broadcastSpec :: Spec+broadcastSpec = around runWithClientServer $+  describe "Broadcaster" $+    it "should broadcast a message to connected clients" $ \(broadcaster, messages) -> do+      _ <- broadcast broadcaster $ Message "broadcast"+      message <- waitForMessage messages+      message `shouldBe` Just "{\"hello\":\"broadcast\"}"+++waitForMessage :: ReceivedMessage -> IO (Maybe Text)+waitForMessage messages = B.listenTimeout messages 100000+++runWithClientServer :: (TestState -> IO a) -> IO a+runWithClientServer action = do+  broadcaster <- newBroadcaster+  messages <- B.new+  isConnected <- E.new++  testWithApplication (return $ withWebSocketBroadcaster broadcaster webSocketService httpApplication) $ \port -> do+      _ <- forkIO $ WS.runClient "localhost" port "" $ clientReceiver messages isConnected+      E.wait isConnected+      action (broadcaster, messages)++  where++    clientReceiver :: ReceivedMessage -> E.Event -> WS.Connection -> IO ()+    clientReceiver receivedMessageBroadcast isConnected connection = do+      E.set isConnected+      _ <- forever $ WS.receiveData connection >>= B.broadcast receivedMessageBroadcast+      return ()++    webSocketService :: WebSocketServer Message Message+    webSocketService _ = return Nothing++    httpApplication :: Application+    httpApplication _ respond = respond $ responseLBS Network.HTTP.Types.status400 [] "Not a WebSocket request"

@@ -0,0 +1,87 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}++module RequestResponseSpec where++import           Elm.WebSocket+import           Test.Hspec++import           Control.Concurrent           (forkIO)+import qualified Control.Concurrent.Broadcast as B+import qualified Control.Concurrent.Event     as E+import           Control.Monad                (forever)+import           Data.Aeson                   (FromJSON, ToJSON, decode, encode)+import           Data.Text.Lazy               (Text)+import           Data.Text.Lazy.Encoding      (decodeUtf8, encodeUtf8)+import           GHC.Generics                 (Generic)+import           Network.HTTP.Types+import           Network.Wai+import           Network.Wai.Handler.Warp     (testWithApplication)+import qualified Network.WebSockets           as WS++data Message+  = Request { question :: String}+  | Response { answer :: String}+  deriving (Eq, Show, Generic)++instance ToJSON Message++instance FromJSON Message++type Requests = B.Broadcast Text++type Responses = B.Broadcast Text++type TestState = (Requests, Responses)+++spec :: Spec+spec = requestResponseSpec+++requestResponseSpec :: Spec+requestResponseSpec =+  around runWithClientServer $+    describe "WebSocket Server" $+      it "should respond to requests" $ \(requests, responses) -> do+        sendRequest requests (Request "hi friend")+        message <- waitForResponse responses+        message `shouldBe` Just (Response "hi friend")+++sendRequest :: ToJSON a => Requests -> a -> IO ()+sendRequest requests message = B.broadcast requests $ decodeUtf8 $ encode message+++waitForResponse :: Responses -> IO (Maybe Message)+waitForResponse responses = do+  json <- B.listenTimeout responses 100000+  return $ json >>= (decode . encodeUtf8)+++runWithClientServer :: (TestState -> IO a) -> IO a+runWithClientServer action = do+  broadcaster <- newBroadcaster+  requests <- B.new+  responses <- B.new+  isConnected <- E.new+  testWithApplication (return $ withWebSocketBroadcaster broadcaster webSocketService httpApplication) $ \port -> do+    _ <- forkIO $ WS.runClient "localhost" port "" $ client requests responses isConnected+    E.wait isConnected+    action (requests, responses)+  where++    client :: Requests -> Responses -> E.Event -> WS.Connection -> IO ()+    client requests responses isConnected connection = do+      E.set isConnected+      forever $+        do request <- B.listen requests+           WS.sendTextData connection request+           WS.receiveData connection >>= B.broadcast responses++    webSocketService :: WebSocketServer Message Message+    webSocketService (Request message) = return $ Just (Response message)+    webSocketService _ = return Nothing++    httpApplication :: Application+    httpApplication _ respond = respond $ responseLBS Network.HTTP.Types.status400 [] "Not a WebSocket request"

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}