Skip to content

Instantly share code, notes, and snippets.

@chshersh
Created March 25, 2019 11:07
Show Gist options
  • Save chshersh/5a4c8e1c0557627859fe93ad0b05dd56 to your computer and use it in GitHub Desktop.
Save chshersh/5a4c8e1c0557627859fe93ad0b05dd56 to your computer and use it in GitHub Desktop.
Comonadic builders
#!/usr/bin/env cabal
{- cabal:
build-depends:
, base ^>= 4.12.0.0
, comonad ^>= 5.0
, pretty-simple ^>= 2.2
, text
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
import Control.Comonad (Comonad (..), (=>>))
import Data.Semigroup (Any (..))
import Data.Text (Text)
import Text.Pretty.Simple (pPrint)
data Settings = Settings
{ settingsHasLibrary :: Any
, settingsGitHub :: Any
, settingsTravis :: Any
} deriving (Show)
instance Semigroup Settings where
Settings a1 b1 c1 <> Settings a2 b2 c2 =
Settings (a1 <> a2) (b1 <> b2) (c1 <> c2)
instance Monoid Settings where
mempty = Settings mempty mempty mempty
data Project = Project
{ projectName :: !Text
, projectHasLibrary :: !Bool
, projectGitHub :: !Bool
, projectTravis :: !Bool
} deriving (Show)
type ProjectBuilder = Settings -> Project
buildProject :: Text -> ProjectBuilder
buildProject projectName Settings{..} = Project
{ projectHasLibrary = getAny settingsHasLibrary
, projectGitHub = getAny settingsGitHub
, projectTravis = getAny settingsTravis
, ..
}
{-
builder =>> f
:: Settings -> Project
= flip extend builder f -- (=>>) definition
= extend f builder -- flip definition
= fmap f (duplicate builder) -- default implementation of extend
= fmap f (\settings1 -> builder . mappend settings1) -- duplicate for arrow
= f . (\settings1 -> builder . mappend settings1) -- Functor instance for arrow
= f . (\settings1 settings2 -> builder $ settings1 <> settings2) -- eta-expanding internal lambda
= \settings -> f $ (\settings1 settings2 -> builder $ settings1 <> settings2) settings -- eta-expanding outer lambda
= \settings -> f $ \settings2 -> builder $ settings <> settings2 -- partially applying lambda
-}
append :: ProjectBuilder -> (ProjectBuilder -> Project) -> ProjectBuilder
append = (=>>)
{-
buildProject "foo" =>> hasLibraryB
:: Settings -> Project
= \settings -> hasLibraryB $ \settings2 -> buildProject "foo" $ settings <> settings2
= \settings -> (\settings2 -> buildProject "foo" $ settings <> settings2) (mempty { settingsHasLibrary = Any True })
= \settings -> buildProject "foo" $ settings <> mempty { settingsHasLibrary = Any True }
-}
hasLibraryB :: ProjectBuilder -> Project
hasLibraryB builder = builder $ mempty { settingsHasLibrary = Any True }
gitHubB :: ProjectBuilder -> Project
gitHubB builder = builder $ mempty { settingsGitHub = Any True }
alwaysTravisB :: ProjectBuilder -> Project
alwaysTravisB builder = builder $ mempty { settingsTravis = Any True }
travisB :: ProjectBuilder -> Project
travisB builder =
let project = extract builder
in project { projectTravis = projectGitHub project }
main :: IO ()
main = do
-- plain
pPrint $ extract $ buildProject "minimal-project"
pPrint $ extract $ buildProject "only-library" =>> hasLibraryB
pPrint $ extract $ buildProject "library-github" =>> hasLibraryB =>> gitHubB
-- dependent: 1 level
pPrint $ extract $ buildProject "travis" =>> travisB
pPrint $ extract $ buildProject "always-travis" =>> alwaysTravisB
pPrint $ extract $ buildProject "github-travis" =>> gitHubB =>> travisB
pPrint $ extract $ buildProject "travis-github" =>> travisB =>> gitHubB
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment