{-# LANGUAGE RankNTypes #-}

module Ondim.State
  ( -- * Namespace maps
    NamespaceMap,
    binding,
    mapToNamespace,
    (#:),
    unbind,

    -- ** Typed expansions
    (##),
    typedExpansion,

    -- ** Polymorphic expansions
    (#*),
    polyExpansion,

    -- ** Templates
    (#%),
    templateData,

    -- ** Textual templates
    (#@),
    textData,

    -- ** Namespaces
    (#.),
    namespace,

    -- * Datatypes
    OndimState (..),
    NamespaceItem (..),
    Namespace (..),

    -- ** Manipulate the whole state
    getOndimS,
    modifyOndimS,
    putOndimS,

    -- ** Manipulate the state by keys
    withSomeExpansion,
    putSomeExpansion,
    withoutExpansions,
    withNamespace,

    -- ** Altering namespaces
    lookup,
    insert,
    delete,
  )
where

import Data.Char (isLetter)
import Data.HashMap.Strict qualified as HMap
import Data.Text qualified as T
import Ondim.Internal.Basic
import Ondim.Internal.Class (OndimNode)
import Data.STRef (readSTRef, modifySTRef', writeSTRef)

-- * User API

-- State manipulation

-- | Get the Ondim state.
getOndimS :: Ondim s (OndimState s)
getOndimS :: forall s. Ondim s (OndimState s)
getOndimS = do
  ref <- ReaderT
  (TraceData, STRef s (OndimState s))
  (ExceptT OndimException (ST s))
  (STRef s (OndimState s))
-> Ondim s (STRef s (OndimState s))
forall s a.
ReaderT
  (TraceData, STRef s (OndimState s))
  (ExceptT OndimException (ST s))
  a
-> Ondim s a
Ondim (ReaderT
   (TraceData, STRef s (OndimState s))
   (ExceptT OndimException (ST s))
   (STRef s (OndimState s))
 -> Ondim s (STRef s (OndimState s)))
-> ReaderT
     (TraceData, STRef s (OndimState s))
     (ExceptT OndimException (ST s))
     (STRef s (OndimState s))
-> Ondim s (STRef s (OndimState s))
forall a b. (a -> b) -> a -> b
$ ((TraceData, STRef s (OndimState s)) -> STRef s (OndimState s))
-> ReaderT
     (TraceData, STRef s (OndimState s))
     (ExceptT OndimException (ST s))
     (STRef s (OndimState s))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (TraceData, STRef s (OndimState s)) -> STRef s (OndimState s)
forall a b. (a, b) -> b
snd
  liftST $ readSTRef ref

modifyOndimS :: (OndimState s -> OndimState s) -> Ondim s ()
modifyOndimS :: forall s. (OndimState s -> OndimState s) -> Ondim s ()
modifyOndimS OndimState s -> OndimState s
f = do
  ref <- ReaderT
  (TraceData, STRef s (OndimState s))
  (ExceptT OndimException (ST s))
  (STRef s (OndimState s))
-> Ondim s (STRef s (OndimState s))
forall s a.
ReaderT
  (TraceData, STRef s (OndimState s))
  (ExceptT OndimException (ST s))
  a
-> Ondim s a
Ondim (ReaderT
   (TraceData, STRef s (OndimState s))
   (ExceptT OndimException (ST s))
   (STRef s (OndimState s))
 -> Ondim s (STRef s (OndimState s)))
-> ReaderT
     (TraceData, STRef s (OndimState s))
     (ExceptT OndimException (ST s))
     (STRef s (OndimState s))
-> Ondim s (STRef s (OndimState s))
forall a b. (a -> b) -> a -> b
$ ((TraceData, STRef s (OndimState s)) -> STRef s (OndimState s))
-> ReaderT
     (TraceData, STRef s (OndimState s))
     (ExceptT OndimException (ST s))
     (STRef s (OndimState s))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (TraceData, STRef s (OndimState s)) -> STRef s (OndimState s)
forall a b. (a, b) -> b
snd
  liftST $ modifySTRef' ref f

putOndimS :: OndimState s -> Ondim s ()
putOndimS :: forall s. OndimState s -> Ondim s ()
putOndimS OndimState s
s = do
  ref <- ReaderT
  (TraceData, STRef s (OndimState s))
  (ExceptT OndimException (ST s))
  (STRef s (OndimState s))
-> Ondim s (STRef s (OndimState s))
forall s a.
ReaderT
  (TraceData, STRef s (OndimState s))
  (ExceptT OndimException (ST s))
  a
-> Ondim s a
Ondim (ReaderT
   (TraceData, STRef s (OndimState s))
   (ExceptT OndimException (ST s))
   (STRef s (OndimState s))
 -> Ondim s (STRef s (OndimState s)))
-> ReaderT
     (TraceData, STRef s (OndimState s))
     (ExceptT OndimException (ST s))
     (STRef s (OndimState s))
-> Ondim s (STRef s (OndimState s))
forall a b. (a -> b) -> a -> b
$ ((TraceData, STRef s (OndimState s)) -> STRef s (OndimState s))
-> ReaderT
     (TraceData, STRef s (OndimState s))
     (ExceptT OndimException (ST s))
     (STRef s (OndimState s))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (TraceData, STRef s (OndimState s)) -> STRef s (OndimState s)
forall a b. (a, b) -> b
snd
  liftST $ writeSTRef ref s

-- | Either bind or unbind an expansion locally.
withSomeExpansion ::
  Text ->
  Maybe (NamespaceItem s) ->
  Ondim s a ->
  Ondim s a
withSomeExpansion :: forall s a.
Text -> Maybe (NamespaceItem s) -> Ondim s a -> Ondim s a
withSomeExpansion Text
name Maybe (NamespaceItem s)
ex Ondim s a
st = do
  pEx <- Text -> Namespace s -> Maybe (NamespaceItem s)
forall m. Text -> Namespace m -> Maybe (NamespaceItem m)
lookup Text
name (Namespace s -> Maybe (NamespaceItem s))
-> (OndimState s -> Namespace s)
-> OndimState s
-> Maybe (NamespaceItem s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OndimState s -> Namespace s
forall s. OndimState s -> Namespace s
expansions (OndimState s -> Maybe (NamespaceItem s))
-> Ondim s (OndimState s) -> Ondim s (Maybe (NamespaceItem s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ondim s (OndimState s)
forall s. Ondim s (OndimState s)
getOndimS
  modifyOndimS \OndimState s
s -> OndimState s
s {expansions = insOrDel ex (expansions s)}
  st <* modifyOndimS \OndimState s
s -> OndimState s
s {expansions = insOrDel pEx (expansions s)}
  where
    insOrDel :: Maybe (NamespaceItem s) -> Namespace s -> Namespace s
insOrDel = (Namespace s -> Namespace s)
-> (NamespaceItem s -> Namespace s -> Namespace s)
-> Maybe (NamespaceItem s)
-> Namespace s
-> Namespace s
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Namespace s -> Namespace s
forall m. Text -> Namespace m -> Namespace m
delete Text
name) (Text -> NamespaceItem s -> Namespace s -> Namespace s
forall m. Text -> NamespaceItem m -> Namespace m -> Namespace m
insert Text
name)

-- | Bind a namespace locally.
withNamespace :: Namespace s -> Ondim s a -> Ondim s a
withNamespace :: forall s a. Namespace s -> Ondim s a -> Ondim s a
withNamespace (Namespace HashMap Text (NamespaceItem s)
exps) Ondim s a
o =
  ((Text, NamespaceItem s) -> Ondim s a -> Ondim s a)
-> Ondim s a -> [(Text, NamespaceItem s)] -> Ondim s a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Text
k, NamespaceItem s
v) -> Text -> Maybe (NamespaceItem s) -> Ondim s a -> Ondim s a
forall s a.
Text -> Maybe (NamespaceItem s) -> Ondim s a -> Ondim s a
withSomeExpansion Text
k (NamespaceItem s -> Maybe (NamespaceItem s)
forall a. a -> Maybe a
Just NamespaceItem s
v)) Ondim s a
o (HashMap Text (NamespaceItem s) -> [(Text, NamespaceItem s)]
forall k v. HashMap k v -> [(k, v)]
HMap.toList HashMap Text (NamespaceItem s)
exps)

-- | Unbind a list of expansions locally.
withoutExpansions :: [Text] -> Ondim s a -> Ondim s a
withoutExpansions :: forall s a. [Text] -> Ondim s a -> Ondim s a
withoutExpansions [Text]
names Ondim s a
o = (Text -> Ondim s a -> Ondim s a)
-> Ondim s a -> [Text] -> Ondim s a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Text -> Maybe (NamespaceItem s) -> Ondim s a -> Ondim s a
forall s a.
Text -> Maybe (NamespaceItem s) -> Ondim s a -> Ondim s a
`withSomeExpansion` Maybe (NamespaceItem s)
forall a. Maybe a
Nothing) Ondim s a
o [Text]
names

-- | Either put or delete an expansion from the state.
putSomeExpansion :: Text -> Maybe (NamespaceItem s) -> Ondim s ()
putSomeExpansion :: forall s. Text -> Maybe (NamespaceItem s) -> Ondim s ()
putSomeExpansion Text
name Maybe (NamespaceItem s)
ex =
  (OndimState s -> OndimState s) -> Ondim s ()
forall s. (OndimState s -> OndimState s) -> Ondim s ()
modifyOndimS \OndimState s
s -> OndimState s
s {expansions = insOrDel ex (expansions s)}
  where
    insOrDel :: Maybe (NamespaceItem s) -> Namespace s -> Namespace s
insOrDel = (Namespace s -> Namespace s)
-> (NamespaceItem s -> Namespace s -> Namespace s)
-> Maybe (NamespaceItem s)
-> Namespace s
-> Namespace s
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Namespace s -> Namespace s
forall m. Text -> Namespace m -> Namespace m
delete Text
name) (Text -> NamespaceItem s -> Namespace s -> Namespace s
forall m. Text -> NamespaceItem m -> Namespace m -> Namespace m
insert Text
name)

infixr 0 #<>

(#<>) :: Text -> Maybe (NamespaceItem m) -> NamespaceMap m
Text
name #<> :: forall m. Text -> Maybe (NamespaceItem m) -> NamespaceMap m
#<> Maybe (NamespaceItem m)
ex = State [(Text, Maybe (NamespaceItem m))] () -> NamespaceMapM m ()
forall m a.
State [(Text, Maybe (NamespaceItem m))] a -> NamespaceMapM m a
NamespaceMapM (State [(Text, Maybe (NamespaceItem m))] () -> NamespaceMapM m ())
-> State [(Text, Maybe (NamespaceItem m))] () -> NamespaceMapM m ()
forall a b. (a -> b) -> a -> b
$ ([(Text, Maybe (NamespaceItem m))]
 -> [(Text, Maybe (NamespaceItem m))])
-> State [(Text, Maybe (NamespaceItem m))] ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((Text
name, Maybe (NamespaceItem m)
ex) (Text, Maybe (NamespaceItem m))
-> [(Text, Maybe (NamespaceItem m))]
-> [(Text, Maybe (NamespaceItem m))]
forall a. a -> [a] -> [a]
:)

-- | Remove a previously added item from the 'NamespaceMap'.
unbind :: Text -> NamespaceMap m
unbind :: forall m. Text -> NamespaceMap m
unbind Text
k = Text
k Text -> Maybe (NamespaceItem m) -> NamespaceMap m
forall m. Text -> Maybe (NamespaceItem m) -> NamespaceMap m
#<> Maybe (NamespaceItem m)
forall a. Maybe a
Nothing

-- Expansions

newtype NamespaceMapM m a = NamespaceMapM (State [(Text, Maybe (NamespaceItem m))] a)
  deriving newtype ((forall a b. (a -> b) -> NamespaceMapM m a -> NamespaceMapM m b)
-> (forall a b. a -> NamespaceMapM m b -> NamespaceMapM m a)
-> Functor (NamespaceMapM m)
forall a b. a -> NamespaceMapM m b -> NamespaceMapM m a
forall a b. (a -> b) -> NamespaceMapM m a -> NamespaceMapM m b
forall m a b. a -> NamespaceMapM m b -> NamespaceMapM m a
forall m a b. (a -> b) -> NamespaceMapM m a -> NamespaceMapM m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall m a b. (a -> b) -> NamespaceMapM m a -> NamespaceMapM m b
fmap :: forall a b. (a -> b) -> NamespaceMapM m a -> NamespaceMapM m b
$c<$ :: forall m a b. a -> NamespaceMapM m b -> NamespaceMapM m a
<$ :: forall a b. a -> NamespaceMapM m b -> NamespaceMapM m a
Functor, Functor (NamespaceMapM m)
Functor (NamespaceMapM m) =>
(forall a. a -> NamespaceMapM m a)
-> (forall a b.
    NamespaceMapM m (a -> b) -> NamespaceMapM m a -> NamespaceMapM m b)
-> (forall a b c.
    (a -> b -> c)
    -> NamespaceMapM m a -> NamespaceMapM m b -> NamespaceMapM m c)
-> (forall a b.
    NamespaceMapM m a -> NamespaceMapM m b -> NamespaceMapM m b)
-> (forall a b.
    NamespaceMapM m a -> NamespaceMapM m b -> NamespaceMapM m a)
-> Applicative (NamespaceMapM m)
forall m. Functor (NamespaceMapM m)
forall a. a -> NamespaceMapM m a
forall m a. a -> NamespaceMapM m a
forall a b.
NamespaceMapM m a -> NamespaceMapM m b -> NamespaceMapM m a
forall a b.
NamespaceMapM m a -> NamespaceMapM m b -> NamespaceMapM m b
forall a b.
NamespaceMapM m (a -> b) -> NamespaceMapM m a -> NamespaceMapM m b
forall m a b.
NamespaceMapM m a -> NamespaceMapM m b -> NamespaceMapM m a
forall m a b.
NamespaceMapM m a -> NamespaceMapM m b -> NamespaceMapM m b
forall m a b.
NamespaceMapM m (a -> b) -> NamespaceMapM m a -> NamespaceMapM m b
forall a b c.
(a -> b -> c)
-> NamespaceMapM m a -> NamespaceMapM m b -> NamespaceMapM m c
forall m a b c.
(a -> b -> c)
-> NamespaceMapM m a -> NamespaceMapM m b -> NamespaceMapM m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall m a. a -> NamespaceMapM m a
pure :: forall a. a -> NamespaceMapM m a
$c<*> :: forall m a b.
NamespaceMapM m (a -> b) -> NamespaceMapM m a -> NamespaceMapM m b
<*> :: forall a b.
NamespaceMapM m (a -> b) -> NamespaceMapM m a -> NamespaceMapM m b
$cliftA2 :: forall m a b c.
(a -> b -> c)
-> NamespaceMapM m a -> NamespaceMapM m b -> NamespaceMapM m c
liftA2 :: forall a b c.
(a -> b -> c)
-> NamespaceMapM m a -> NamespaceMapM m b -> NamespaceMapM m c
$c*> :: forall m a b.
NamespaceMapM m a -> NamespaceMapM m b -> NamespaceMapM m b
*> :: forall a b.
NamespaceMapM m a -> NamespaceMapM m b -> NamespaceMapM m b
$c<* :: forall m a b.
NamespaceMapM m a -> NamespaceMapM m b -> NamespaceMapM m a
<* :: forall a b.
NamespaceMapM m a -> NamespaceMapM m b -> NamespaceMapM m a
Applicative, Applicative (NamespaceMapM m)
Applicative (NamespaceMapM m) =>
(forall a b.
 NamespaceMapM m a -> (a -> NamespaceMapM m b) -> NamespaceMapM m b)
-> (forall a b.
    NamespaceMapM m a -> NamespaceMapM m b -> NamespaceMapM m b)
-> (forall a. a -> NamespaceMapM m a)
-> Monad (NamespaceMapM m)
forall m. Applicative (NamespaceMapM m)
forall a. a -> NamespaceMapM m a
forall m a. a -> NamespaceMapM m a
forall a b.
NamespaceMapM m a -> NamespaceMapM m b -> NamespaceMapM m b
forall a b.
NamespaceMapM m a -> (a -> NamespaceMapM m b) -> NamespaceMapM m b
forall m a b.
NamespaceMapM m a -> NamespaceMapM m b -> NamespaceMapM m b
forall m a b.
NamespaceMapM m a -> (a -> NamespaceMapM m b) -> NamespaceMapM m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall m a b.
NamespaceMapM m a -> (a -> NamespaceMapM m b) -> NamespaceMapM m b
>>= :: forall a b.
NamespaceMapM m a -> (a -> NamespaceMapM m b) -> NamespaceMapM m b
$c>> :: forall m a b.
NamespaceMapM m a -> NamespaceMapM m b -> NamespaceMapM m b
>> :: forall a b.
NamespaceMapM m a -> NamespaceMapM m b -> NamespaceMapM m b
$creturn :: forall m a. a -> NamespaceMapM m a
return :: forall a. a -> NamespaceMapM m a
Monad)

{- | 'NamespaceMap' provides a monad interface for defining namespaces
   declaratively. You should enable the @BlockArguments@ extension when using
   it. For instance:

@
'Ondim.expandChildren' myNode
  \`'binding'\` do
    "something" '##' myTypedExp
    "is-cow" '#*' ifElse isCow
    "name" '#@' \"Joana\"
    "properties" '#.' do
      "age" '#@' show age
      "state" '#@' "hungry"
@
-}
type NamespaceMap m = NamespaceMapM m ()

infixr 0 #:

-- | Infix to add a 'NamespaceItem' to a 'NamespaceMap'.
(#:) :: Text -> NamespaceItem m -> NamespaceMap m
Text
name #: :: forall m. Text -> NamespaceItem m -> NamespaceMap m
#: NamespaceItem m
ex = Text
name Text -> Maybe (NamespaceItem m) -> NamespaceMap m
forall m. Text -> Maybe (NamespaceItem m) -> NamespaceMap m
#<> NamespaceItem m -> Maybe (NamespaceItem m)
forall a. a -> Maybe a
Just NamespaceItem m
ex

typedExpansion :: (HasCallStack, Typeable t) => Expansion m t -> NamespaceItem m
typedExpansion :: forall t m.
(HasCallStack, Typeable t) =>
Expansion m t -> NamespaceItem m
typedExpansion = DefinitionSite -> Expansion m t -> NamespaceItem m
forall a s.
Typeable a =>
DefinitionSite -> Expansion s a -> NamespaceItem s
TypedExpansion DefinitionSite
callStackSite

infixr 0 ##

{- | Infix to add an 'Expansion' to a 'NamespaceMap'.

@
name '##' expansion = name '#:' 'typedExpansion' expansion
@
-}
(##) :: (HasCallStack, Typeable t) => Text -> Expansion m t -> NamespaceMap m
Text
name ## :: forall t m.
(HasCallStack, Typeable t) =>
Text -> Expansion m t -> NamespaceMap m
## Expansion m t
ex = Text
name Text -> NamespaceItem m -> NamespaceMap m
forall m. Text -> NamespaceItem m -> NamespaceMap m
#: Expansion m t -> NamespaceItem m
forall t m.
(HasCallStack, Typeable t) =>
Expansion m t -> NamespaceItem m
typedExpansion Expansion m t
ex

templateData :: forall a m. (HasCallStack, OndimNode a) => a -> NamespaceItem m
templateData :: forall a m. (HasCallStack, OndimNode a) => a -> NamespaceItem m
templateData = DefinitionSite -> a -> NamespaceItem m
forall a s. OndimNode a => DefinitionSite -> a -> NamespaceItem s
TemplateData DefinitionSite
callStackSite

infixr 0 #%

{- | Infix to add a template (any type with an 'OndimNode' instance) to a
   'NamespaceMap'.

@
name '#%' template = name '#:' 'templateData' template
@
-}
(#%) :: (HasCallStack, OndimNode a) => Text -> a -> NamespaceMap m
Text
name #% :: forall a m.
(HasCallStack, OndimNode a) =>
Text -> a -> NamespaceMap m
#% a
ex = Text
name Text -> NamespaceItem m -> NamespaceMap m
forall m. Text -> NamespaceItem m -> NamespaceMap m
#: a -> NamespaceItem m
forall a m. (HasCallStack, OndimNode a) => a -> NamespaceItem m
templateData a
ex

textData :: (HasCallStack) => Text -> NamespaceItem m
textData :: forall m. HasCallStack => Text -> NamespaceItem m
textData = Text -> NamespaceItem m
forall a m. (HasCallStack, OndimNode a) => a -> NamespaceItem m
templateData

infixr 0 #@

{- | Infix to add a textual data to a 'NamespaceMap'. Just a specialized version
   of '#%'.

@
name '#@' text = name '#:' 'textData' text
@
-}
(#@) :: (HasCallStack) => Text -> Text -> NamespaceMap m
#@ :: forall m. HasCallStack => Text -> Text -> NamespaceMap m
(#@) = Text -> Text -> NamespaceMap m
forall a m.
(HasCallStack, OndimNode a) =>
Text -> a -> NamespaceMap m
(#%)

polyExpansion :: (HasCallStack) => PolyExpansion m -> NamespaceItem m
polyExpansion :: forall m. HasCallStack => PolyExpansion m -> NamespaceItem m
polyExpansion = DefinitionSite -> PolyExpansion m -> NamespaceItem m
forall s. DefinitionSite -> PolyExpansion s -> NamespaceItem s
PolyExpansion DefinitionSite
callStackSite

infixr 0 #*

{- | Infix to add a t'PolyExpansion' to a 'NamespaceMap'.

@
name '#*' expansion = name '#:' 'polyExpansion' expansion
@
-}
(#*) :: (HasCallStack) => Text -> PolyExpansion m -> NamespaceMap m
Text
name #* :: forall m. HasCallStack => Text -> PolyExpansion m -> NamespaceMap m
#* PolyExpansion m
ex = Text
name Text -> NamespaceItem m -> NamespaceMap m
forall m. Text -> NamespaceItem m -> NamespaceMap m
#: PolyExpansion m -> NamespaceItem m
forall m. HasCallStack => PolyExpansion m -> NamespaceItem m
polyExpansion Expansion m a
PolyExpansion m
ex

-- | Runs the 'NamespaceMap' monad to get a 'Namespace'.
mapToNamespace :: NamespaceMap m -> Namespace m
mapToNamespace :: forall m. NamespaceMap m -> Namespace m
mapToNamespace (NamespaceMapM State [(Text, Maybe (NamespaceItem m))] ()
ex) = ((Text, NamespaceItem m) -> Namespace m -> Namespace m)
-> Namespace m -> [(Text, NamespaceItem m)] -> Namespace m
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Text, NamespaceItem m) -> Namespace m -> Namespace m
forall {m}. (Text, NamespaceItem m) -> Namespace m -> Namespace m
go Namespace m
forall a. Monoid a => a
mempty [(Text, NamespaceItem m)]
exps
  where
    go :: (Text, NamespaceItem m) -> Namespace m -> Namespace m
go = (Text -> NamespaceItem m -> Namespace m -> Namespace m)
-> (Text, NamespaceItem m) -> Namespace m -> Namespace m
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> NamespaceItem m -> Namespace m -> Namespace m
forall m. Text -> NamespaceItem m -> Namespace m -> Namespace m
insert
    exps :: [(Text, NamespaceItem m)]
exps = ((Text, Maybe (NamespaceItem m)) -> Maybe (Text, NamespaceItem m))
-> [(Text, Maybe (NamespaceItem m))] -> [(Text, NamespaceItem m)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Text, Maybe (NamespaceItem m)) -> Maybe (Text, NamespaceItem m)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => (Text, m a) -> m (Text, a)
sequence ([(Text, Maybe (NamespaceItem m))] -> [(Text, NamespaceItem m)])
-> [(Text, Maybe (NamespaceItem m))] -> [(Text, NamespaceItem m)]
forall a b. (a -> b) -> a -> b
$ State [(Text, Maybe (NamespaceItem m))] ()
-> [(Text, Maybe (NamespaceItem m))]
-> [(Text, Maybe (NamespaceItem m))]
forall s a. State s a -> s -> s
execState State [(Text, Maybe (NamespaceItem m))] ()
ex []

namespace :: NamespaceMap m -> NamespaceItem m
namespace :: forall m. NamespaceMap m -> NamespaceItem m
namespace = Namespace m -> NamespaceItem m
forall s. Namespace s -> NamespaceItem s
NamespaceData (Namespace m -> NamespaceItem m)
-> (NamespaceMap m -> Namespace m)
-> NamespaceMap m
-> NamespaceItem m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamespaceMap m -> Namespace m
forall m. NamespaceMap m -> Namespace m
mapToNamespace

infixr 0 #.

{- | Infix to nest a 'NamespaceMap' inside a 'NamespaceMap'.

@
name '#.' nsMap = name '#:' 'namespace' nsMap
@
-}
(#.) :: Text -> NamespaceMap m -> NamespaceMap m
Text
name #. :: forall m. Text -> NamespaceMap m -> NamespaceMap m
#. NamespaceMap m
ex = Text
name Text -> NamespaceItem m -> NamespaceMap m
forall m. Text -> NamespaceItem m -> NamespaceMap m
#: NamespaceMap m -> NamespaceItem m
forall m. NamespaceMap m -> NamespaceItem m
namespace NamespaceMap m
ex

{- | Infix version of 'withNamespace' meant to bind expansions more conveniently
   by using 'NamespaceMap's.
-}
binding ::
  Ondim s a ->
  NamespaceMap s ->
  Ondim s a
binding :: forall s a. Ondim s a -> NamespaceMap s -> Ondim s a
binding Ondim s a
o (NamespaceMapM State [(Text, Maybe (NamespaceItem s))] ()
exps) =
  let kvs :: [(Text, Maybe (NamespaceItem s))]
kvs = State [(Text, Maybe (NamespaceItem s))] ()
-> [(Text, Maybe (NamespaceItem s))]
-> [(Text, Maybe (NamespaceItem s))]
forall s a. State s a -> s -> s
execState State [(Text, Maybe (NamespaceItem s))] ()
exps []
   in (Ondim s a -> (Text, Maybe (NamespaceItem s)) -> Ondim s a)
-> Ondim s a -> [(Text, Maybe (NamespaceItem s))] -> Ondim s a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (((Text, Maybe (NamespaceItem s)) -> Ondim s a -> Ondim s a)
-> Ondim s a -> (Text, Maybe (NamespaceItem s)) -> Ondim s a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((Text, Maybe (NamespaceItem s)) -> Ondim s a -> Ondim s a)
 -> Ondim s a -> (Text, Maybe (NamespaceItem s)) -> Ondim s a)
-> ((Text, Maybe (NamespaceItem s)) -> Ondim s a -> Ondim s a)
-> Ondim s a
-> (Text, Maybe (NamespaceItem s))
-> Ondim s a
forall a b. (a -> b) -> a -> b
$ (Text -> Maybe (NamespaceItem s) -> Ondim s a -> Ondim s a)
-> (Text, Maybe (NamespaceItem s)) -> Ondim s a -> Ondim s a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Maybe (NamespaceItem s) -> Ondim s a -> Ondim s a
forall s a.
Text -> Maybe (NamespaceItem s) -> Ondim s a -> Ondim s a
withSomeExpansion) Ondim s a
o [(Text, Maybe (NamespaceItem s))]
kvs

splitNamespaceKey :: Text -> [Text]
splitNamespaceKey :: Text -> [Text]
splitNamespaceKey = (Char -> Bool) -> Text -> [Text]
T.split (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-' Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isLetter Char
c))

lookupNamespaceItem' :: [Text] -> Namespace m -> Maybe (NamespaceItem m)
lookupNamespaceItem' :: forall m. [Text] -> Namespace m -> Maybe (NamespaceItem m)
lookupNamespaceItem' [Text]
keys (Namespace HashMap Text (NamespaceItem m)
e) = [Text] -> HashMap Text (NamespaceItem m) -> Maybe (NamespaceItem m)
forall {s}.
[Text] -> HashMap Text (NamespaceItem s) -> Maybe (NamespaceItem s)
go [Text]
keys HashMap Text (NamespaceItem m)
e
  where
    go :: [Text] -> HashMap Text (NamespaceItem s) -> Maybe (NamespaceItem s)
go [] HashMap Text (NamespaceItem s)
_ = Maybe (NamespaceItem s)
forall a. Maybe a
Nothing
    go [Text
k] HashMap Text (NamespaceItem s)
m = Text -> HashMap Text (NamespaceItem s) -> Maybe (NamespaceItem s)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup Text
k HashMap Text (NamespaceItem s)
m
    go (Text
k : [Text]
ks) HashMap Text (NamespaceItem s)
m = case Text -> HashMap Text (NamespaceItem s) -> Maybe (NamespaceItem s)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup Text
k HashMap Text (NamespaceItem s)
m of
      Just (NamespaceData (Namespace HashMap Text (NamespaceItem s)
n)) -> [Text] -> HashMap Text (NamespaceItem s) -> Maybe (NamespaceItem s)
go [Text]
ks HashMap Text (NamespaceItem s)
n
      Just {} -> Maybe (NamespaceItem s)
forall a. Maybe a
Nothing
      Maybe (NamespaceItem s)
Nothing -> Maybe (NamespaceItem s)
forall a. Maybe a
Nothing

lookup :: Text -> Namespace m -> Maybe (NamespaceItem m)
lookup :: forall m. Text -> Namespace m -> Maybe (NamespaceItem m)
lookup = [Text] -> Namespace m -> Maybe (NamespaceItem m)
forall m. [Text] -> Namespace m -> Maybe (NamespaceItem m)
lookupNamespaceItem' ([Text] -> Namespace m -> Maybe (NamespaceItem m))
-> (Text -> [Text])
-> Text
-> Namespace m
-> Maybe (NamespaceItem m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
splitNamespaceKey

insertNamespaceItem' :: [Text] -> NamespaceItem m -> Namespace m -> Namespace m
insertNamespaceItem' :: forall m. [Text] -> NamespaceItem m -> Namespace m -> Namespace m
insertNamespaceItem' [Text]
keys NamespaceItem m
e (Namespace HashMap Text (NamespaceItem m)
es) = HashMap Text (NamespaceItem m) -> Namespace m
forall m. HashMap Text (NamespaceItem m) -> Namespace m
Namespace (HashMap Text (NamespaceItem m) -> Namespace m)
-> HashMap Text (NamespaceItem m) -> Namespace m
forall a b. (a -> b) -> a -> b
$ [Text]
-> HashMap Text (NamespaceItem m) -> HashMap Text (NamespaceItem m)
go [Text]
keys HashMap Text (NamespaceItem m)
es
  where
    go :: [Text]
-> HashMap Text (NamespaceItem m) -> HashMap Text (NamespaceItem m)
go [] = HashMap Text (NamespaceItem m) -> HashMap Text (NamespaceItem m)
forall a. a -> a
id
    go [Text
k] = Text
-> NamespaceItem m
-> HashMap Text (NamespaceItem m)
-> HashMap Text (NamespaceItem m)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HMap.insert Text
k NamespaceItem m
e
    go (Text
k : [Text]
ks) =
      ((Maybe (NamespaceItem m) -> Maybe (NamespaceItem m))
 -> Text
 -> HashMap Text (NamespaceItem m)
 -> HashMap Text (NamespaceItem m))
-> Text
-> (Maybe (NamespaceItem m) -> Maybe (NamespaceItem m))
-> HashMap Text (NamespaceItem m)
-> HashMap Text (NamespaceItem m)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe (NamespaceItem m) -> Maybe (NamespaceItem m))
-> Text
-> HashMap Text (NamespaceItem m)
-> HashMap Text (NamespaceItem m)
forall k v.
(Eq k, Hashable k) =>
(Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v
HMap.alter Text
k ((Maybe (NamespaceItem m) -> Maybe (NamespaceItem m))
 -> HashMap Text (NamespaceItem m)
 -> HashMap Text (NamespaceItem m))
-> (Maybe (NamespaceItem m) -> Maybe (NamespaceItem m))
-> HashMap Text (NamespaceItem m)
-> HashMap Text (NamespaceItem m)
forall a b. (a -> b) -> a -> b
$
        NamespaceItem m -> Maybe (NamespaceItem m)
forall a. a -> Maybe a
Just
          (NamespaceItem m -> Maybe (NamespaceItem m))
-> (Maybe (NamespaceItem m) -> NamespaceItem m)
-> Maybe (NamespaceItem m)
-> Maybe (NamespaceItem m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Namespace m -> NamespaceItem m
forall s. Namespace s -> NamespaceItem s
NamespaceData
          (Namespace m -> NamespaceItem m)
-> (Maybe (NamespaceItem m) -> Namespace m)
-> Maybe (NamespaceItem m)
-> NamespaceItem m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text (NamespaceItem m) -> Namespace m
forall m. HashMap Text (NamespaceItem m) -> Namespace m
Namespace
          (HashMap Text (NamespaceItem m) -> Namespace m)
-> (Maybe (NamespaceItem m) -> HashMap Text (NamespaceItem m))
-> Maybe (NamespaceItem m)
-> Namespace m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
            Just (NamespaceData (Namespace HashMap Text (NamespaceItem m)
n)) -> [Text]
-> HashMap Text (NamespaceItem m) -> HashMap Text (NamespaceItem m)
go [Text]
ks HashMap Text (NamespaceItem m)
n
            Maybe (NamespaceItem m)
_notNamespace -> [Text]
-> HashMap Text (NamespaceItem m) -> HashMap Text (NamespaceItem m)
go [Text]
ks HashMap Text (NamespaceItem m)
forall a. Monoid a => a
mempty

insert :: Text -> NamespaceItem m -> Namespace m -> Namespace m
insert :: forall m. Text -> NamespaceItem m -> Namespace m -> Namespace m
insert = [Text] -> NamespaceItem m -> Namespace m -> Namespace m
forall m. [Text] -> NamespaceItem m -> Namespace m -> Namespace m
insertNamespaceItem' ([Text] -> NamespaceItem m -> Namespace m -> Namespace m)
-> (Text -> [Text])
-> Text
-> NamespaceItem m
-> Namespace m
-> Namespace m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
splitNamespaceKey

deleteNamespaceItem' :: [Text] -> Namespace m -> Namespace m
deleteNamespaceItem' :: forall m. [Text] -> Namespace m -> Namespace m
deleteNamespaceItem' [Text]
keys v :: Namespace m
v@(Namespace HashMap Text (NamespaceItem m)
es) =
  case [Text]
keys of
    [] -> Namespace m
v
    [Text
k] -> HashMap Text (NamespaceItem m) -> Namespace m
forall m. HashMap Text (NamespaceItem m) -> Namespace m
Namespace (HashMap Text (NamespaceItem m) -> Namespace m)
-> HashMap Text (NamespaceItem m) -> Namespace m
forall a b. (a -> b) -> a -> b
$ Text
-> HashMap Text (NamespaceItem m) -> HashMap Text (NamespaceItem m)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HMap.delete Text
k HashMap Text (NamespaceItem m)
es
    (Text
k : [Text]
ks) -> HashMap Text (NamespaceItem m) -> Namespace m
forall m. HashMap Text (NamespaceItem m) -> Namespace m
Namespace (HashMap Text (NamespaceItem m) -> Namespace m)
-> HashMap Text (NamespaceItem m) -> Namespace m
forall a b. (a -> b) -> a -> b
$ [Text]
-> Text
-> HashMap Text (NamespaceItem m)
-> HashMap Text (NamespaceItem m)
forall {k} {m}.
Hashable k =>
[Text]
-> k -> HashMap k (NamespaceItem m) -> HashMap k (NamespaceItem m)
go [Text]
ks Text
k HashMap Text (NamespaceItem m)
es
  where
    go :: [Text]
-> k -> HashMap k (NamespaceItem m) -> HashMap k (NamespaceItem m)
go [Text]
ks = (NamespaceItem m -> Maybe (NamespaceItem m))
-> k -> HashMap k (NamespaceItem m) -> HashMap k (NamespaceItem m)
forall k a.
(Eq k, Hashable k) =>
(a -> Maybe a) -> k -> HashMap k a -> HashMap k a
HMap.update \case
      (NamespaceData Namespace m
n) ->
        case [Text] -> Namespace m -> Namespace m
forall m. [Text] -> Namespace m -> Namespace m
deleteNamespaceItem' [Text]
ks Namespace m
n of
          x :: Namespace m
x@(Namespace HashMap Text (NamespaceItem m)
hmap)
            | HashMap Text (NamespaceItem m) -> Bool
forall k v. HashMap k v -> Bool
HMap.null HashMap Text (NamespaceItem m)
hmap -> Maybe (NamespaceItem m)
forall a. Maybe a
Nothing
            | Bool
otherwise -> NamespaceItem m -> Maybe (NamespaceItem m)
forall a. a -> Maybe a
Just (NamespaceItem m -> Maybe (NamespaceItem m))
-> NamespaceItem m -> Maybe (NamespaceItem m)
forall a b. (a -> b) -> a -> b
$ Namespace m -> NamespaceItem m
forall s. Namespace s -> NamespaceItem s
NamespaceData Namespace m
x
      NamespaceItem m
x -> NamespaceItem m -> Maybe (NamespaceItem m)
forall a. a -> Maybe a
Just NamespaceItem m
x

delete :: Text -> Namespace m -> Namespace m
delete :: forall m. Text -> Namespace m -> Namespace m
delete = [Text] -> Namespace m -> Namespace m
forall m. [Text] -> Namespace m -> Namespace m
deleteNamespaceItem' ([Text] -> Namespace m -> Namespace m)
-> (Text -> [Text]) -> Text -> Namespace m -> Namespace m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
splitNamespaceKey