Free monads sample project

Only builds for now with the DSL fleshed out.

Signed-off-by: Sanchayan Maity <maitysanchayan@gmail.com>
This commit is contained in:
Sanchayan Maity 2020-07-22 19:03:13 +05:30
commit 7547bcefad
11 changed files with 288 additions and 0 deletions

3
.gitignore vendored Normal file
View file

@ -0,0 +1,3 @@
free-monad-example.cabal
.stack-work/
*~

30
LICENSE Normal file
View file

@ -0,0 +1,30 @@
Copyright Sanchayan Maity (c) 2020
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 Author name here 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.

1
README.md Normal file
View file

@ -0,0 +1 @@
# free-monad-example

2
Setup.hs Normal file
View file

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

6
app/Main.hs Normal file
View file

@ -0,0 +1,6 @@
module Main where
import Lib
main :: IO ()
main = putStrLn "Free monad example"

13
hie.yaml Normal file
View file

@ -0,0 +1,13 @@
cradle:
stack:
- path: "./src"
component: "free-monad-example:lib"
- path: "./app/Main.hs"
component: "free-monad-example:exe:free-monad-example-exe"
- path: "./app/Paths_free_monad_example.hs"
component: "free-monad-example:exe:free-monad-example-exe"
- path: "./test"
component: "free-monad-example:test:free-monad-example-test"

56
package.yaml Normal file
View file

@ -0,0 +1,56 @@
name: free-monad-example
version: 0.1.0.0
github: "sanchayanmaity/free-monad-example"
license: BSD3
author: "Sanchayan Maity"
maintainer: "maitysanchayan@gmail.com"
copyright: "2020 Sanchayan Maity"
extra-source-files:
- README.md
# Metadata used when publishing your package
# synopsis: Short description of your package
# category: Web
# To avoid duplicated efforts in documentation and dealing with the
# complications of embedding Haddock markup inside cabal files, it is
# common to point users to the README.md file.
description: Please see the README on GitHub at <https://github.com/sanchayanmaity/free-monad-example#readme>
dependencies:
- base >= 4.7 && < 5
- free
- postgresql-simple
- servant
- servant-server
- text
ghc-options:
- -Wall
- -Wunused-binds
library:
source-dirs: src
executables:
free-monad-example-exe:
main: Main.hs
source-dirs: app
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- free-monad-example
tests:
free-monad-example-test:
main: Spec.hs
source-dirs: test
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- free-monad-example

97
src/Lib.hs Normal file
View file

@ -0,0 +1,97 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Lib where
import Control.Exception
import Control.Monad.Free.Church
import Database.PostgreSQL.Simple
import Data.Proxy
import Data.Text
import Servant.API
import Servant.Server
data SqlDBMethodF next where
SqlDBMethod :: FromRow r => (Connection -> Query -> IO [r]) -> ([r] -> next) -> SqlDBMethodF next
SqlThrowException :: Exception e => e -> (a -> next) -> SqlDBMethodF next
instance Functor SqlDBMethodF where
fmap f (SqlDBMethod runner next) = SqlDBMethod runner (f . next)
fmap f (SqlThrowException exceptionMsg next) = SqlThrowException exceptionMsg (f . next)
type SqlDb = F SqlDBMethodF
sqlDbMethod :: FromRow r => (Connection -> Query -> IO [r]) -> SqlDb [r]
sqlDbMethod action = liftF $ SqlDBMethod action id
sqlThrowException :: Exception e => e -> SqlDb a
sqlThrowException exception = liftF $ SqlThrowException exception id
interpretSqlDBMethod :: Connection -> Query -> SqlDBMethodF a -> IO a
interpretSqlDBMethod conn squery (SqlDBMethod runner next) = next <$> runner conn squery
interpretSqlDBMethod _ _ (SqlThrowException exception _) = throwIO exception
runDB :: Connection -> Query -> SqlDb a -> IO a
runDB conn squery = foldF $ interpretSqlDBMethod conn squery
type SampleAPI = Get '[JSON] Text
data ServeF next where
ServeMethod :: (forall api. HasServer api '[] => (Proxy api -> IO a)) -> (a -> next) -> ServeF next
instance Functor ServeF where
fmap f (ServeMethod runner next) = ServeMethod runner (f . next)
type Serve = F ServeF
serveMethod :: (forall api. HasServer api '[] => (Proxy api -> IO a)) -> Serve a
serveMethod action = liftF $ ServeMethod action id
interpretServeMethod :: HasServer api '[] => Proxy api -> ServeF a -> IO a
interpretServeMethod api (ServeMethod runner next) = next <$> runner api
runServe :: HasServer api '[] => Proxy api -> Serve a -> IO a
runServe api = foldF $ interpretServeMethod api
data LoggerMethodF next where
LogMessage :: Text -> (() -> next) -> LoggerMethodF next
instance Functor LoggerMethodF where
fmap f (LogMessage msg next) = LogMessage msg (f . next)
type Logger = F LoggerMethodF
logMessage :: Text -> Logger ()
logMessage logMsg = liftF $ LogMessage logMsg id
interpretLoggerMethod :: LoggerMethodF a -> IO a
interpretLoggerMethod (LogMessage msg next) = next <$> print msg
runLogger :: Logger a -> IO a
runLogger = foldF interpretLoggerMethod
data DSLMethod next where
LogMsg :: Logger () -> (() -> next) -> DSLMethod next
ServeHttp :: HasServer api '[] => Proxy api -> Serve a -> (a -> next) -> DSLMethod next
RunQuery :: FromRow r => Connection -> Query -> SqlDb [r] -> ([r] -> next) -> DSLMethod next
instance Functor DSLMethod where
fmap f (LogMsg msg next) = LogMsg msg (f . next)
fmap f (ServeHttp api act next) = ServeHttp api act (f . next)
fmap f (RunQuery conn squery act next) = RunQuery conn squery act (f . next)
type DSL = F DSLMethod
interpretDSLMethod :: DSLMethod a -> IO a
interpretDSLMethod (LogMsg logger next) =
fmap next $ runLogger logger
interpretDSLMethod (ServeHttp api server next) =
fmap next $ runServe api server
interpretDSLMethod (RunQuery conn squery sql next) =
fmap next $ runDB conn squery sql
runDSL :: DSL a -> IO a
runDSL = foldF interpretDSLMethod

66
stack.yaml Normal file
View file

@ -0,0 +1,66 @@
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# https://docs.haskellstack.org/en/stable/yaml_configuration/
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
#
# The location of a snapshot can be provided as a file or url. Stack assumes
# a snapshot provided as a file might change, whereas a url resource does not.
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-15.15
# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# subdirs:
# - auto-update
# - wai
packages:
- .
# Dependency packages to be pulled from upstream that are not in the resolver.
# These entries can reference officially published versions as well as
# forks / in-progress versions pinned to a git hash. For example:
#
# extra-deps:
# - acme-missiles-0.3
# - git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
#
# extra-deps: []
# Override default flag values for local packages and extra-deps
# flags: {}
# Extra package databases containing global packages
# extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=2.3"
#
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor

12
stack.yaml.lock Normal file
View file

@ -0,0 +1,12 @@
# This file was autogenerated by Stack.
# You should not edit this file by hand.
# For more information, please see the documentation at:
# https://docs.haskellstack.org/en/stable/lock_files
packages: []
snapshots:
- completed:
size: 496112
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/15.yaml
sha256: 86169722ad0056ffc9eacc157ef80ee21d7024f92c0d2961c89ccf432db230a3
original: lts-15.15

2
test/Spec.hs Normal file
View file

@ -0,0 +1,2 @@
main :: IO ()
main = putStrLn "Test suite not yet implemented"