Optics.Core.elm

module Optics.Core exposing
  ( Optic
  , id
  , o
  
  , lens
  , prism
  , traversal

  , view
  , viewSome
  , viewAll
  , is
  , review
  , over

  , Lens
  , Prism
  , Traversal

  , SimpleOptic
  , SimpleLens
  , SimplePrism
  , SimpleTraversal
  )

{- | An attempt to port https://hackage.haskell.org/package/lens to Elm.
-}

import Either exposing (Either (..))

import Debug

{- | Type-level "yes". Is a 1 type.
-}
type alias Y = ()

{- | Type-level "no". Is a 0 type.
-}
type N = N N

{- | A lens, prism or a traversal.

    If `pr` is `N`  it  is not a prism.
    If `pr` is free it _is_    a prism.
    
    If `ls` is `N`  it   is not a lens.
    If `ls` is free it  _is_    a lens.
    
    It is always a traversal.

    When you compose 
     (Optic notAPrism1 notALens1)
       `o`
     (Optic notAPrism2 notALens2)
       ===
         Optic
           (and notAPrism1 notAPrism2)
           (and notALens1  notALens2)

    And the unification variables track the subtyping.

    The type Optic is also opaque, you can't pull stuff out of it
    and use methods you are prohibited to.
-}
type Optic pr ls s t a b = Optic
  { view   : (ls, s) -> a
  , review : (pr, b) -> t
  , viewAll : s -> List a
  , update : (a -> b) -> s -> t
  }

{- | The restricted cases.

     The only prism that is also a lens is an identity,
     which is already accessible as `id`.

     We have to shovel around unification variables, though.
     Can't do anything with it.
-}
type alias Lens      ls s t a b = Optic N  ls s t a b
type alias Prism     pr s t a b = Optic pr N  s t a b
type alias Traversal    s t a b = Optic N  N  s t a b

{- | Simplified monomorphic interfaces.
-}
type alias SimpleOptic     pr ls s a = Optic     pr ls s s a a
type alias SimpleLens         ls s a = Lens         ls s s a a
type alias SimplePrism     pr    s a = Prism     pr    s s a a
type alias SimpleTraversal       s a = Traversal       s s a a

absurd : N -> a
absurd (N n) = absurd n

{- | A lens constructor.
     
     Creates "not a Prism", because `id` is already accessible.
-}
lens : (s -> a) -> (s -> b -> t) -> Lens ls s t a b
lens v upd = Optic
  { view    = \(_, a) -> v a
  , viewAll = \a -> [v a]
  , review  = \(n, b) -> absurd n
  , update  = \f s -> upd s <| f <| v s
  }

{- | A prism constructor.
     
     Creates "not a lens", because `id` is already accessible.
-}
prism : (b -> t) -> (s -> Either t a) -> Prism pr s t a b
prism back split = Optic
  { viewAll = \s -> case split s of
      Left  _ -> []
      Right a -> [a]
  , view = \(n, s) -> absurd n
  , review = \(_, b) -> back b
  , update = \f s -> case split s of
      Left  t -> t
      Right a -> back <| f a
  }

{- | A traversal constructor.
     
     Creates "not a Prism and not a Lens".

    Notice that it requires (s -> List a) parameter, because there
    is no Foldable typeclass in Elm and therefore no `Foldable.toList`,
    so we have to provide it somehow.
-}
traversal : (s -> List a) -> ((a -> b) -> s -> t) -> Traversal s t a b
traversal v u = Optic
  { viewAll = v
  , view    = \(n, _) -> absurd n
  , review  = \(n, _) -> absurd n
  , update  = u
  }

{- | An empty element. Is a prism, a lens and a traversal.
-}
id : SimpleLens ls s s
id = Optic
  { viewAll = List.singleton
  , view   = Tuple.second
  , review = Tuple.second
  , update = identity
  }

{- | Optical composition.

     Performs subtyping on the type level.
-}
o : Optic pr ls s t a b -> Optic pr ls a b x y -> Optic pr ls s t x y
o (Optic f) (Optic g) = Optic
  { viewAll = f.viewAll >> List.concatMap g.viewAll
  , view   = \(y, s) -> g.view   (y, f.view   (y, s))
  , review = \(y, b) -> f.review (y, g.review (y, b))
  , update = g.update >> f.update
  }

{- | Retrieve the only element using a lens.
-}
view : Optic pr Y s t a b -> s -> a
view (Optic l) s = l.view ((), s)

{- | Retrieve up to one element using an optic.
-}
viewSome : Optic pr ls s t a b -> s -> Maybe a
viewSome (Optic l) = l.viewAll >> List.head

{- | Check if s is related to a prism.

     Note:
       You can change `Y` to `pr` here and it will still compile.
       I restricted it to prisms, because semantics for traversals
       would be questionable.
-}
is : Optic Y ls s t a b -> s -> Bool
is (Optic l) = l.viewAll >> List.isEmpty >> not

{- | Retrieve all elements using a traversal.
-}
viewAll : Optic pr ls s t a b -> s -> List a
viewAll (Optic l) = l.viewAll

{- | Use prism to reconstruct.
-}
review : Optic Y ls s t a b -> b -> t
review (Optic l) s = l.review ((), s)

{- | Update over any traversable.
-}
over : Optic pr ls s t a b -> (a -> b) -> (s -> t)
over (Optic l) = l.update

Optics.Simple.elm

module Optics.Simple exposing
  ( just_
  , nothing_
  , left_
  , right_
  , only
  , each
  , every
  , first
  , second
  )

{- | Basic optics.
-}

import Either exposing (Either (..))
import Array  exposing (Array (..))

import Optics.Core exposing (..)

just_ : Prism pr (Maybe a) (Maybe b) a b
just_ = prism Just <| \s -> case s of
  Just a  -> Right a
  Nothing -> Left Nothing

nothing_ : SimplePrism pr (Maybe a) ()
nothing_ = prism (always Nothing) <| \s -> case s of
  Nothing -> Right ()
  _       -> Left s

left_ : Prism pr (Either a c) (Either b c) a b
left_ = prism Left <| \s -> case s of
  Left  a -> Right a
  Right c -> Left (Right c)

right_ : Prism pr (Either c a) (Either c b) a b
right_ = prism Right <| \s -> case s of
  Right a -> Right a
  Left  c -> Left (Left c)

only : (a -> Bool) -> SimplePrism pr a a
only pred = prism identity <| \s ->
  if pred s then Right s else Left s

each : Traversal (List a) (List b) a b
each = traversal identity List.map

every : Traversal (Array a) (Array b) a b
every = traversal Array.toList Array.map

first : Lens n (a, c) (b, c) a b
first = lens Tuple.first (\(_, b) a -> (a, b))

second : Lens n (c, a) (c, b) a b
second = lens Tuple.second (\(a, _) b -> (a, b))

Optics.Test.elm

module Optics.Test exposing (..)

import Optics.Core   exposing (..)
import Optics.Simple exposing (..)

import Html exposing (Html)

test1 : Int
test1 = view (o first second) ((1, 2), 3)

test2 : Maybe Int
test2 = viewSome (o each (o first (o just_ second))) [(Just (1, 2), 3)]

test3 : List (Maybe (Int, Int), Int)
test3 = over (o each (o first (o just_ second))) ((+) 40) [(Just (1, 2), 3)]

test4 : Maybe (Maybe Int)
test4 = review (o just_ just_) 1

eq : String -> a -> a -> Html b
eq msg a b =
  Html.div []
    [ Html.text
        <| if a == b
           then msg ++ ": Pass"
           else msg ++ ": " ++ Debug.toString a ++ " != " ++ Debug.toString b
    ]

main : Html a
main = Html.ul []
  [ eq "deep access"    test1   2
  , eq "composition"    test2  (Just 2)
  , eq "deep update"    test3 [(Just (1, 42), 3)]
  , eq "reconstruction" test4  (Just (Just 1))
  ]