LoginSignup
TrendQuestionOfficial EventOfficial ColumnOpportunitiesOrganization
13
9

More than 3 years have passed since last update.

PureScript Advent Calendar 2017 Day 12

@legokichi

posted at

updated at

Functor, Applicative, Monad, Comonad, MonadTrans, Profunctor, Strong, Arrow, Choice, ArrowChoice, Costrong, ArrowLoop

purescript,Monad,Arrow

Functor, Applicative, Monad, Comonad

monad.jpg

Kleisli 圏の射 >=>

kleisli.jpg

MonadTrans

trans.jpg

Profunctor, Strong, Arrow

arrow.jpg

Arrow, ArrowLoop

arrow2.jpg

Profunctor, Strong, Arrow, Choice, ArrowChoice, Costrong, ArrowLoop

PureScript による Strong, Costrong, Choice のデモコード
PureScript は正格評価のため遅延評価が必要な Costrong (->) の loop == unfirst を実装していない
個々では型だけ合わせて擬似的に再現したが unfirst, unsecond は本来の意図通りのフィードバックループとしては機能しない

-- purescript 0.13.3

import Control.Applicative (pure)
import Control.Bind ((>>=), discard, bind)
import Control.Semigroupoid ((>>>))
import Data.Eq (class Eq, (==))
import Data.Either (Either(Left, Right))
import Data.Function (($), (#))
import Data.Profunctor (class Profunctor dimap, arr)
import Data.Profunctor.Choice ((+++), (|||))
import Data.Profunctor.Costrong (class Costrong, unfirst unsecond)
import Data.Profunctor.Strong ((&&&), (***), first, second)
import Data.Semigroup ((<>))
import Data.Show (class Show, show)
import Data.Tuple (Tuple(Tuple))
import Data.Unit (Unit, unit)
import Effect (Effect)
import Effect.Console (log)

main :: Effect Unit
main = do
  log "Arrow Demo"
  log $ ("arrow: " <> _) $ show $ A # a2bc >>> bc2cc >>> cc2aa >>> (second a2b)
  log $ ("choice: " <> _) $ show $ Left A # (a2b +++ a2c) >>> (b2c +++ c2a) >>> (c2a +++ a2b) >>> (a2c ||| b2c)
  log $ ("loop: " <> _) $ show $ let Function' a2a = unfirst (Function' ooo) in a2a $ a2a A
  log $ ("loop2: " <> _) $ show $ let Function' f = unfirst (Function' iii) in f true
  pure unit
  where
  ooo :: (Tuple A (Maybe Int)) -> (Tuple A (Maybe Int))
  ooo = case _ of
    Tuple a (Just c) ->
      Tuple a $ Just $ spy "ooo" $ c + 1
    Tuple a _ -> Tuple a $ Just $ spy "ooo" 0

  iii :: (Tuple Boolean (Unit -> Int)) -> (Tuple Boolean (Unit -> Int))
  iii (Tuple reset lazy) = case reset of
    true -> Tuple false \_ -> spy "iii" 0
    false -> Tuple false $ \_ -> spy "iii" $ 1 + lazy unit

  a2b :: A -> B
  a2b A = B

  a2c:: A -> C
  a2c A = C

  b2c :: B -> C
  b2c B = C

  c2a :: C -> A
  c2a C = A

  a2bc :: A -> (Tuple B C)
  a2bc = (a2b &&& a2c)

  bc2cc :: (Tuple B C) -> (Tuple C C)
  bc2cc = first b2c

  cc2aa :: (Tuple C A) -> (Tuple A A)
  cc2aa = (c2a *** c2a)

--- Costrong (->) === ArrowLoop のために必要
--- PureScript は正格評価のため遅延評価が必要な Costrong (->) を実装できない!!! 

newtype Function' a b = Function' (a -> b)

instance profunctorFn' :: Profunctor Function' where
  dimap a2b c2d (Function' b2c) = Function' (a2b >>> b2c >>> c2d)

instance costrongFn' :: Costrong Function' where
  unfirst :: forall a b c. (Function' (Tuple a c) (Tuple b c)) -> Function' a b
  unfirst (Function' f) =
    Function' \a ->
      let
        (Tuple b c) = f (Tuple a c)
      in
        b
    where
    c = undefined -- 正格評価の PureScript ではフィードバック値 c の初期値を遅延評価で算出できない!!!
  unsecond :: forall a b c. (Function' (Tuple a b) (Tuple a c)) -> Function' b c
  unsecond (Function' f) =
    Function' \b ->
      let
        (Tuple a c) = f (Tuple a b)
      in
        c
    where
    a = undefined -- 正格評価の PureScript ではフィードバック値 a の初期値を遅延評価で算出できない!!!

data A = A
derive instance eqA :: Eq A
instance showA :: Show A where
  show A = "A"

data B = B
derive instance eqB :: Eq B
instance showB :: Show B where
  show B = "B"

data C = C
derive instance eqC :: Eq C
instance showC :: Show C where
  show C = "C"

data D = D
derive instance eqD :: Eq D
instance showD :: Show D where
  show D = "D"

Kleisli Triple

todo...

referencce

reference2

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
What you can do with signing up
Sign upLogin
13
9