{-# OPTIONS_GHC -fno-warn-orphans #-}

module Pandora.Paradigm.Structure.Rose (Rose) where

import Pandora.Core.Functor (type (:.), type (:=))
import Pandora.Core.Morphism ((!), (%))
import Pandora.Pattern.Category ((.))
import Pandora.Pattern.Functor.Covariant (Covariant ((<$>)))
import Pandora.Pattern.Functor.Extractable (extract)
import Pandora.Pattern.Functor.Avoidable (Avoidable (empty))
import Pandora.Pattern.Functor.Divariant (($))
import Pandora.Paradigm.Primary.Functor.Maybe (Maybe (Just, Nothing), maybe)
import Pandora.Paradigm.Primary.Functor.Product (Product ((:*:)))
import Pandora.Paradigm.Primary.Functor.Tagged (Tagged (Tag))
import Pandora.Paradigm.Primary.Transformer.Construction (Construction (Construct), deconstruct)
import Pandora.Paradigm.Controlflow.Joint.Schemes.TU (TU (TU))
import Pandora.Paradigm.Inventory.Store (Store (Store))
import Pandora.Paradigm.Structure.Stack (Stack)
import Pandora.Paradigm.Structure.Ability.Nonempty (Nonempty)
import Pandora.Paradigm.Structure.Ability.Focusable (Focusable (Focus, top, singleton))
import Pandora.Paradigm.Structure.Ability.Substructure (Substructure (Substructural, sub))

type Rose = TU Covariant Covariant Maybe (Construction Stack)

instance Focusable Rose where
        type Focus Rose a = Maybe a
        top (TU Nothing) = Store $ Nothing :*: TU . (<$>) (Construct % empty)
        top (TU (Just x)) = Store $ Just (extract x) :*: maybe
                (TU $ Just x) -- TODO: Nothing at top's lens - should it remove something?
                (TU . Just . Construct % deconstruct x)
        singleton = TU . Just . Construct % empty

instance Substructure Just Rose where
        type Substructural Just Rose a = Stack :. Construction Stack := a
        sub (TU Nothing) = Store $ Tag (TU Nothing) :*: (TU Nothing !)
        sub (TU (Just (Construct x xs))) = Store $ Tag xs :*: TU . Just . Construct x . extract

type instance Nonempty Rose = Construction Stack

instance Substructure Just (Construction Stack) where
        type Substructural Just (Construction Stack) a = Stack :. Construction Stack := a
        sub (Construct x xs) = Store $ Tag xs :*: Construct x . extract

instance Focusable (Construction Stack) where
        type Focus (Construction Stack) a = a
        top rose = Store $ extract rose :*: Construct % deconstruct rose
        singleton = Construct % empty