commit 7547bcefadc397336478b8952f63229777a0432e Author: Sanchayan Maity Date: Wed Jul 22 19:03:13 2020 +0530 Free monads sample project Only builds for now with the DSL fleshed out. Signed-off-by: Sanchayan Maity diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..c0e6244 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +free-monad-example.cabal +.stack-work/ +*~ diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..d3696cf --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 index 0000000..32aa02a --- /dev/null +++ b/README.md @@ -0,0 +1 @@ +# free-monad-example diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..4b50bda --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Lib + +main :: IO () +main = putStrLn "Free monad example" diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000..1cdb982 --- /dev/null +++ b/hie.yaml @@ -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" diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..daa22fb --- /dev/null +++ b/package.yaml @@ -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 + +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 diff --git a/src/Lib.hs b/src/Lib.hs new file mode 100644 index 0000000..3e675ee --- /dev/null +++ b/src/Lib.hs @@ -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 diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..1dce4ea --- /dev/null +++ b/stack.yaml @@ -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 diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..caca58d --- /dev/null +++ b/stack.yaml.lock @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..cd4753f --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"