Haskell × Elm のサンプルアプリケーションを書いてみた

{-# LANGUAGE DataKinds     #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}

module Todo where

import Data.Aeson (FromJSON, ToJSON)
import Data.Proxy (Proxy (..))
import Elm (ElmType)
import GHC.Generics (Generic)
import Servant.API
import Web.Internal.FormUrlEncoded (FromForm)

data Todo = Todo
  { todoId :: Int
  , title  :: String
  , done   :: Bool
  } deriving (Generic, Show)

instance FromJSON Todo
instance ToJSON Todo
instance FromForm Todo -- (1)
instance ElmType Todo  -- (2)

type CRUD = "todos" :> Get '[JSON] [Todo]
       :<|> "todos" :> ReqBody '[JSON, FormUrlEncoded] Todo :> Post '[JSON] Todo
       :<|> "todos" :> Capture "id" Int :> ReqBody '[JSON, FormUrlEncoded] Todo :> Put '[JSON] ()
       :<|> "todos" :> Capture "id" Int :> Delete '[JSON] ()

crud :: Proxy CRUD
crud = Proxy

{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators     #-}

module Main where

import Control.Arrow (second)
import Control.Concurrent.STM (TVar, atomically, modifyTVar, newTVar, readTVar, writeTVar)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Proxy (Proxy (..))
import qualified Network.Wai.Handler.Warp  as Warp
import Servant.API ((:<|>) (..), (:>), Get, Raw)
import Servant.EDE (HTML, loadTemplates)
import Servant.Server (Server, serve)
import Servant.Utils.StaticFiles (serveDirectoryFileServer)
import Todo (Todo (..))
import qualified Todo

main :: IO ()
main = do
  db <- atomically $ newTVar (length initTodoList, IntMap.fromList initTodoList)
  _ <- loadTemplates api [] "."
  putStrLn "Listening on port 8080"
  Warp.run 8080 $ serve api (server db)

type API = Get '[HTML "index.html"] Object
      :<|> "static" :> Raw
      :<|> Todo.CRUD

api :: Proxy API
api = Proxy

server :: TVar (Int, IntMap Todo) -> Server API
server db = index
       :<|> serveDirectoryFileServer "static"
       :<|> getTodos
       :<|> postTodo
       :<|> putTodoId
       :<|> deleteTodoId
  where
    index = pure mempty
    getTodos = liftIO $ IntMap.elems . snd <$> atomically (readTVar db)
    postTodo todo = liftIO . atomically $ do
      (maxId, m) <- readTVar db
      let
        newId = maxId + 1
        newTodo = todo { todoId = newId }
      writeTVar db (newId, IntMap.insert newId newTodo m)
      pure newTodo
    putTodoId tid todo =
      liftIO . atomically . modifyTVar db . second $ IntMap.insert tid todo
    deleteTodoId tid   =
      liftIO . atomically . modifyTVar db . second $ IntMap.delete tid

initTodoList :: [(Int, Todo)]
initTodoList =
  [ (1, Todo 1 "アドベントカレンダーを書く" True)
  , (2, Todo 2 "Haskellで仕事する" False)
  , (3, Todo 3 "寝る" False)
  ]

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Data.Proxy  (Proxy (..))
import Elm
import Servant.Elm
import Shelly (run_, shelly)
import Todo (CRUD, Todo)

elmOpts :: ElmOptions
elmOpts =
  defElmOptions
    { urlPrefix = Static "http://localhost:8080" }

spec :: Spec
spec = Spec ["Generated", "TodoAPI"]
            (defElmImports
             : toElmTypeSource    (Proxy :: Proxy Todo)
             : toElmDecoderSource (Proxy :: Proxy Todo)
             : toElmEncoderSource (Proxy :: Proxy Todo)
             : generateElmForAPIWith elmOpts  (Proxy :: Proxy CRUD))

main :: IO ()
main = do
  specsToDir [spec] "elm-src"
  shelly $
    run_ "elm-make" ["elm-src/Main.elm", "--output=static/main.js"]

type alias Todo =
    { id : Int
    , title : String
    , done : Bool
    }

type Todo = Record
  '[ "id" >: Int
   , "title" >: String
   , "done" >: Bool
   ]

instance Forall (KeyValue KnownSymbol FromHttpApiData) xs => FromForm (Record xs) where
  fromForm f = hgenerateFor (Proxy :: Proxy (KeyValue KnownSymbol FromHttpApiData))
    $ \m -> let k = symbolVal (proxyAssocKey m) in Field <$> parseUnique (fromString k) f

instance FromHttpApiData a => FromHttpApiData (Identity a) where
  parseUrlPiece = fmap Identity . parseUrlPiece

class ElmType a where
  toElmType :: a -> ElmDatatype

data ElmDatatype
  = ElmDatatype Text ElmConstructor
  | ElmPrimitive ElmPrimitive
  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)

>> :set -XDeriveGeneric -XDeriveAnyClass
>> data Hoge = Hoge { xxx :: Int, yyy :: String } deriving (Show, Generic, ElmType)
>> toElmType (undefined :: Hoge)
ElmDatatype "Hoge" (RecordConstructor "Hoge" (Values (ElmField "xxx" (ElmPrimitiveRef EInt)) (ElmField "yyy" (ElmPrimitiveRef (EList (ElmPrimitive EChar))))))

class ToElmValue a where
  toElmValue :: a -> ElmValue

instance Forall (KeyValue KnownSymbol ElmType) xs => ToElmValue (Record xs) where
  toElmValue rec = hfoldMap getConst'
    $ hzipWith (\(Comp Dict) v -> Const'
        $ ElmField (fromString . symbolVal $ proxyAssocKey v) (elmTypeToElmValue . toElmType $ getField v))
      (library :: Comp Dict (KeyValue KnownSymbol ElmType) :* xs) rec

instance ElmType a => ElmType (Identity a) where
  toElmType (Identity a) = toElmType a

elmTypeToElmValue :: ElmDatatype -> ElmValue
elmTypeToElmValue (ElmDatatype name _) = ElmRef name
elmTypeToElmValue (ElmPrimitive prim)  = ElmPrimitiveRef prim

{-# LANGUAGE TypeSynonymInstances #-}

instance ElmType Todo where
  toElmType = toElmRecordType "Todo"

toElmRecordType :: ToElmValue a => Text -> a -> ElmDatatype
toElmRecordType name = ElmDatatype name . RecordConstructor name . toElmValue

>> toElmType (undefined :: Todo)
ElmDatatype "Todo" (RecordConstructor "Todo" *** Exception: Prelude.undefined
CallStack (from HasCallStack):
  error, called at libraries\base\GHC\Err.hs:79:14 in base:GHC.Err
  undefined, called at <interactive>:15:12 in interactive:Ghci1

example :: Todo
example = #id @= 1
       <: #title @= "hoge"
       <: #done @= True
       <: emptyRecord

spec :: Spec
spec = Spec ["Generated", "TodoAPI"]
            (defElmImports
             : toElmTypeSource    example -- here
             : toElmDecoderSource example -- here
             : toElmEncoderSource example -- here
             : generateElmForAPIWith elmOpts  (Proxy :: Proxy CRUD))