packages feed

elision (empty) → 0.1.0.0

raw patch · 5 files changed

+299/−0 lines, 5 filesdep +basedep +elisiondep +profunctorssetup-changed

Dependencies added: base, elision, profunctors

Files

+ LICENSE view
@@ -0,0 +1,10 @@+Copyright (c) 2016, Alex Crough+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. 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.++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 HOLDER 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ elision.cabal view
@@ -0,0 +1,30 @@+name:                elision+version:             0.1.0.0+synopsis:            A data structure over two functions to be linked together at a later time.+homepage:            http://github.com/crough/elision#readme+license:             BSD2+license-file:        LICENSE+author:              Alex Crough+maintainer:          alex@crough.io+copyright:           2016 Alex Crough+category:            Control+build-type:          Simple+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Control.Arrow.Elision+  default-language:    Haskell2010+  build-depends:       base        >= 4.7   && < 5+                     , profunctors >= 5.1.2++executable example+  hs-source-dirs:      example+  main-is:             Main.hs+  default-language:    Haskell2010+  build-depends:       base+                     , elision++source-repository head+  type:     git+  location: https://github.com/crough/elision
+ example/Main.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE GADTs, TypeOperators #-}+module Main where++import Data.Elision+import Data.Functor.Identity++--------------------------------------------------------------------------------+type User = String++type Pass = String++data AuthLevel+  = Unauthorized+  | GuestAccess+  | AdminAccess+  deriving (Show, Eq, Ord, Enum)++instance Monoid AuthLevel where+  mempty = Unauthorized+  mappend = max++data Tty a where+  ReadLine ::           Tty String+  PutLine  :: String -> Tty ()++data Auth a where+  Guest ::         Pass -> Auth AuthLevel+  Admin :: User -> Pass -> Auth AuthLevel++--------------------------------------------------------------------------------+readLine :: Elision Tty () String+readLine = initial ReadLine++putLine :: Elision Tty String ()+putLine = simple <<^ PutLine++guestAccess :: Elision Auth Pass AuthLevel+guestAccess = simple <<^ Guest++adminAccess :: Elision Auth (User,Pass) AuthLevel+adminAccess = simple <<^ uncurry Admin++anyAccess :: Elision Auth (User,Pass) AuthLevel+anyAccess = uncurry mappend ^<< adminAccess &&& (guestAccess <<^ snd)++--------------------------------------------------------------------------------+ttyIO :: Tty a -> IO a+ttyIO action =+  case action of+    ReadLine  -> getLine+    PutLine s -> putStrLn s++ttyPure :: String -> Tty a -> Identity a+ttyPure line action =+  case action of+    ReadLine  -> pure line+    PutLine _ -> pure ()++authPure :: Auth a -> Identity a+authPure credentials =+  case credentials of+    Guest password ->+      if password == "guest_password"+         then pure GuestAccess+         else pure Unauthorized++    Admin user password ->+      if (user,password) == ("admin", "admin_password")+         then pure AdminAccess+         else pure Unauthorized++authIO :: Auth a -> IO a+authIO = pure . runIdentity . authPure++--------------------------------------------------------------------------------+getCredentials :: Elision Tty () (User,Pass)+getCredentials =+  do putLine <~ "Enter your username (blank if guest)"+     user    <- readLine+     putLine <~ "Enter your password"+     pass    <- readLine+     pure (user,pass)++interactiveAuth :: Elision (Tty // Auth) () AuthLevel+interactiveAuth = anyAccess </ getCredentials++main :: IO ()+main =+  do auth <- complete' (ttyIO // authIO) interactiveAuth+     print auth
+ src/Control/Arrow/Elision.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE ExplicitNamespaces, NoImplicitPrelude, RankNTypes, TupleSections,+             TypeOperators #-}+{- |+Module      : Control.Arrow.Elision+Description : Two functions with a missing "link" to be completed at a later time.+Copyright   : (c) 2016 Alex Crough+License     : BSD2+Maintainer  : alex@crough.io+Stability   : Experimental+Portability : RankNTypes, TupleSection, TypeOperators+-}+module Control.Arrow.Elision+       ( -- * Types+         Elision+       , Elision'++         -- * Elision manipulation functions+       , complete+       , complete'+       , elide+       , initial+       , simple+       , unelide+       , unelide'++         -- * Combining Interpreters+       , Sum+       , type (//)+       , (//)+       , left'+       , right'+       , (/>)+       , (</)++         -- * Reexports+       , module Control.Arrow+       , module Data.Profunctor+       )+       where++import Control.Applicative (Applicative (..))+import Control.Arrow       (Arrow (..), ArrowApply (..), ArrowChoice (..),+                            ArrowMonad, second, (&&&), (***), (+++), (<<<),+                            (<<^), (>>>), (>>^), (^<<), (^>>), (|||))+import Control.Category    (Category (..))+import Control.Monad       (Functor (..), Monad (..), (=<<))+import Data.Either         (Either (..), either)+import Data.Function       (const, ($))+import Data.Profunctor     (Profunctor (..))++--------------------------------------------------------------------------------+-- | A lens-esque type that can be used to "skip" part of a function.+--+-- An 'Elision' can be used in the common interpreter pattern, in which case+-- @f@ represents the DSL type, @a@ represents the input of a function and @b@+-- represents the output.+--+-- Use 'complete' or 'unelide' to deconstruct the type.+newtype Elision f a b =+  Elision (forall m. Monad m => (forall t. f t -> m t) -> a -> m b)++instance Functor (Elision f a) where+  fmap = rmap++instance Applicative (Elision f a) where+  pure x    = Elision (const (const (pure x)))+  e0 <*> e1 = Elision $ \e' arg -> unelide e0 e' arg <*> unelide e1 e' arg++instance Monad (Elision f a) where+  e >>= fn = Elision $ \e' arg -> complete e' arg . fn =<< complete e' arg e++instance Profunctor (Elision f) where+  dimap l r e = Elision $ \e' -> dimap l (fmap r) (unelide e e')++instance Category (Elision f) where+  id      = Elision $ \_  arg -> pure arg+  e1 . e0 = Elision $ \e' arg -> unelide e1 e' =<< unelide e0 e' arg++instance Arrow (Elision f) where+  arr   fn = Elision $ \_ -> pure . fn+  first e  = Elision $ \e' (x,y) -> fmap (,y) (unelide e e' x)++instance ArrowChoice (Elision f) where+  left e = Elision $ \e' arg ->+    case arg of+      Left l  -> fmap Left (unelide e e' l)+      Right r -> pure (Right r)++instance ArrowApply (Elision f) where+  app = Elision $ \e' (arr', arg) -> complete' e' (arr' <<^ const arg)++--------------------------------------------------------------------------------+-- | The type of the simplist elision, where @unelide eli f = f@+type Elision' f a = Elision f (f a) a++--------------------------------------------------------------------------------+-- | Deconstruct an Elision, returning its inner type.+unelide :: Monad m => Elision f a b -> (forall c. f c -> m c) -> a -> m b+unelide (Elision e) = e++--------------------------------------------------------------------------------+-- | Like 'unelide', but applies the unit type to the function immediately.+unelide' :: Monad m => Elision f () b -> (forall c. f c -> m c) -> m b+unelide' e fn = unelide e fn ()++--------------------------------------------------------------------------------+-- | Construct an interpreter for an elision out of a function an initial+-- argument.+complete :: Monad m => (forall c. f c -> m c) -> a -> Elision f a b -> m b+complete fn arg (Elision e) = e fn arg++--------------------------------------------------------------------------------+-- | Like 'complete', but the unit type never has to be provided.+complete' :: Monad m => (forall c. f c -> m c) -> Elision f () b -> m b+complete' fn = complete fn ()++--------------------------------------------------------------------------------+-- | The simplest elision, effectively the identity function.+simple :: Elision' f a+simple = Elision (\f x -> f x)++--------------------------------------------------------------------------------+-- | Apply a value to an elision immediately.+initial :: f a -> Elision f () a+initial x = simple <<^ const x++--------------------------------------------------------------------------------+-- | Create an elision out of two functions to be completed at a later date.+elide :: (a -> f c) -> (c -> b) -> Elision f a b+elide f g = Elision $ \e' x -> dimap f (fmap g) e' x++--------------------------------------------------------------------------------+-- | Either @f a@ or @g a@.+newtype Sum f g a =+  Sum { runSum :: Either (f a) (g a) }++--------------------------------------------------------------------------------+-- | A type synonym for 'Sum' to create harmony with the '//' function.+type a // b = Sum a b++--------------------------------------------------------------------------------+-- | Create a function that can complete an elision of a sum out of two+-- functions that can complete each individual parts.+(//) :: (forall b. f b -> m b) -> (forall b. g b -> m b) -> Sum f g a -> m a+f // g = either f g . runSum++--------------------------------------------------------------------------------+-- | Like 'left', but over the first type argument.+left' :: Elision f a b -> Elision (f // g) a b+left' e = Elision $ \e' -> unelide e (e' . Sum . Left)++--------------------------------------------------------------------------------+-- | Like 'right', but over the first type argument.+right' :: Elision g a b -> Elision (f // g) a b+right' e = Elision $ \e' -> unelide e (e' . Sum . Right)++--------------------------------------------------------------------------------+-- | Send the output of the left to the input of right, and add their @f@+-- types together.+(/>) :: Elision f a b -> Elision g b c -> Elision (f // g) a c+a /> b = right' b . left' a++--------------------------------------------------------------------------------+-- | Send the output of the right to the input of the left, and add their @f@+-- types together.+(</) :: Elision f b c -> Elision g a b -> Elision (f // g) a c+b </ a = left' b . right' a