{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-- |
-- Module: Language.KURE.Path
-- Copyright: (c) 2012--2021 The University of Kansas
-- License: BSD3
--
-- Maintainer: Neil Sculthorpe <neil.sculthorpe@ntu.ac.uk>
-- Stability: beta
-- Portability: ghc
--
-- This module provides several Path abstractions, used for denoting a path through the tree.

module Language.KURE.Path
       (
         -- * Paths
         -- | A @crumb@ is a value that denotes which child node to descended into.
         --   That is, a path through a tree is specified by a \"trail of breadcrumbs\".
         --   For example, if the children are numbered, 'Int' could be used as the @crumb@ type.
         --   'SnocPath' is useful for recording where you have been, as it is cheap to keep adding to the end of the list as you travel further.
         --   'Path' is useful for recording where you intend to go, as you'll need to access it in order.

         -- ** Relative Paths
         Path
         -- ** Snoc Paths
       , SnocPath(..)
       , ExtendPath(..)
       , snocPathToPath
       , pathToSnocPath
       , singletonSnocPath
       , lastCrumb
         -- ** Absolute and Local Paths
       , LocalPath
       , AbsolutePath
       , ReadPath(..)
       , lastCrumbT
       , absPathT
       )
where

import Control.Arrow ((>>^))

#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail (MonadFail)
#endif

import Language.KURE.Transform
import Language.KURE.Combinators.Transform
import Language.KURE.Injection

-------------------------------------------------------------------------------

-- | A 'Path' is just a list.
--   The intent is that a path represents a route through the tree from an arbitrary node.
type Path crumb = [crumb]

-------------------------------------------------------------------------------

-- | A 'SnocPath' is a list stored in reverse order.
newtype SnocPath crumb = SnocPath [crumb] deriving SnocPath crumb -> SnocPath crumb -> Bool
(SnocPath crumb -> SnocPath crumb -> Bool)
-> (SnocPath crumb -> SnocPath crumb -> Bool)
-> Eq (SnocPath crumb)
forall crumb. Eq crumb => SnocPath crumb -> SnocPath crumb -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SnocPath crumb -> SnocPath crumb -> Bool
$c/= :: forall crumb. Eq crumb => SnocPath crumb -> SnocPath crumb -> Bool
== :: SnocPath crumb -> SnocPath crumb -> Bool
$c== :: forall crumb. Eq crumb => SnocPath crumb -> SnocPath crumb -> Bool
Eq

instance Semigroup (SnocPath crumb) where
  (<>) :: SnocPath crumb -> SnocPath crumb -> SnocPath crumb
  (SnocPath [crumb]
p1) <> :: SnocPath crumb -> SnocPath crumb -> SnocPath crumb
<> (SnocPath [crumb]
p2) = [crumb] -> SnocPath crumb
forall crumb. [crumb] -> SnocPath crumb
SnocPath ([crumb]
p2 [crumb] -> [crumb] -> [crumb]
forall a. [a] -> [a] -> [a]
++ [crumb]
p1)
  {-# INLINE (<>) #-}

instance Monoid (SnocPath crumb) where
   mempty :: SnocPath crumb
   mempty :: SnocPath crumb
mempty = [crumb] -> SnocPath crumb
forall crumb. [crumb] -> SnocPath crumb
SnocPath []
   {-# INLINE mempty #-}

instance Functor SnocPath where
   fmap :: (a -> b) -> SnocPath a -> SnocPath b
   fmap :: (a -> b) -> SnocPath a -> SnocPath b
fmap a -> b
f (SnocPath [a]
p) = [b] -> SnocPath b
forall crumb. [crumb] -> SnocPath crumb
SnocPath ((a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map a -> b
f [a]
p)
   {-# INLINE fmap #-}

-- | Convert a 'Path' to a 'SnocPath'.  O(n).
pathToSnocPath :: Path crumb -> SnocPath crumb
pathToSnocPath :: Path crumb -> SnocPath crumb
pathToSnocPath Path crumb
p = Path crumb -> SnocPath crumb
forall crumb. [crumb] -> SnocPath crumb
SnocPath (Path crumb -> Path crumb
forall a. [a] -> [a]
reverse Path crumb
p)
{-# INLINE pathToSnocPath #-}

-- | Convert a 'SnocPath' to a 'Path'.  O(n).
snocPathToPath :: SnocPath crumb -> Path crumb
snocPathToPath :: SnocPath crumb -> Path crumb
snocPathToPath (SnocPath Path crumb
p) = Path crumb -> Path crumb
forall a. [a] -> [a]
reverse Path crumb
p
{-# INLINE snocPathToPath #-}

instance Show crumb => Show (SnocPath crumb) where
   show :: SnocPath crumb -> String
   show :: SnocPath crumb -> String
show = Path crumb -> String
forall a. Show a => a -> String
show (Path crumb -> String)
-> (SnocPath crumb -> Path crumb) -> SnocPath crumb -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnocPath crumb -> Path crumb
forall crumb. SnocPath crumb -> Path crumb
snocPathToPath
   {-# INLINE show #-}

singletonSnocPath :: crumb -> SnocPath crumb
singletonSnocPath :: crumb -> SnocPath crumb
singletonSnocPath crumb
cr = [crumb] -> SnocPath crumb
forall crumb. [crumb] -> SnocPath crumb
SnocPath [crumb
cr]
{-# INLINE singletonSnocPath #-}

-- | Get the last crumb from a 'SnocPath'.  O(1).
lastCrumb :: SnocPath crumb -> Maybe crumb
lastCrumb :: SnocPath crumb -> Maybe crumb
lastCrumb (SnocPath [crumb]
p) = [crumb] -> Maybe crumb
forall a. [a] -> Maybe a
safehead [crumb]
p
{-# INLINE lastCrumb #-}

-------------------------------------------------------------------------------

-- | A class of things that can be extended by crumbs.
--   Typically, @c@ is a context type.
--   The typical use is to extend an 'AbsolutePath' stored in the context (during tree traversal).
--   Note however, that if an 'AbsolutePath' is not stored in the context, an instance can still be declared with @('@@' crumb)@ as an identity operation.
class ExtendPath c crumb | c -> crumb where
  -- | Extend the current 'AbsolutePath' by one crumb.
  (@@) :: c -> crumb -> c

-- | A 'SnocPath' from the root.
type AbsolutePath = SnocPath

-- | A 'SnocPath' from a local origin.
type LocalPath = SnocPath

-- | A class for contexts that store the current 'AbsolutePath', allowing transformations to depend upon it.
class ReadPath c crumb | c -> crumb where
  -- | Read the current absolute path.
  absPath :: c -> AbsolutePath crumb

-- | Lifted version of 'absPath'.
absPathT :: (ReadPath c crumb, Monad m) => Transform c m a (AbsolutePath crumb)
absPathT :: Transform c m a (AbsolutePath crumb)
absPathT = Transform c m a c
forall (m :: * -> *) c a. Monad m => Transform c m a c
contextT Transform c m a c
-> (c -> AbsolutePath crumb)
-> Transform c m a (AbsolutePath crumb)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ c -> AbsolutePath crumb
forall c crumb. ReadPath c crumb => c -> AbsolutePath crumb
absPath
{-# INLINE absPathT #-}

-- | Lifted version of 'lastCrumb'.
lastCrumbT :: (ReadPath c crumb, MonadFail m) => Transform c m a crumb
lastCrumbT :: Transform c m a crumb
lastCrumbT = (c -> m crumb) -> Transform c m a crumb
forall k c (m :: k -> *) (b :: k) a.
(c -> m b) -> Transform c m a b
contextonlyT (String -> Maybe crumb -> m crumb
forall (m :: * -> *) a u.
(MonadFail m, Injection a u) =>
String -> u -> m a
projectWithFailMsgM (ShowS
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"lastCrumbT failed: at the root, no crumbs yet.") (Maybe crumb -> m crumb) -> (c -> Maybe crumb) -> c -> m crumb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnocPath crumb -> Maybe crumb
forall crumb. SnocPath crumb -> Maybe crumb
lastCrumb (SnocPath crumb -> Maybe crumb)
-> (c -> SnocPath crumb) -> c -> Maybe crumb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> SnocPath crumb
forall c crumb. ReadPath c crumb => c -> AbsolutePath crumb
absPath)
{-# INLINE lastCrumbT #-}

-------------------------------------------------------------------------------

-- | Any 'SnocPath' can be extended.
instance ExtendPath (SnocPath crumb) crumb where
   (@@) :: SnocPath crumb -> crumb -> SnocPath crumb
   (SnocPath [crumb]
crs) @@ :: SnocPath crumb -> crumb -> SnocPath crumb
@@ crumb
cr = [crumb] -> SnocPath crumb
forall crumb. [crumb] -> SnocPath crumb
SnocPath (crumb
crcrumb -> [crumb] -> [crumb]
forall a. a -> [a] -> [a]
:[crumb]
crs)
   {-# INLINE (@@) #-}

-- | The simplest instance of 'ReadPath' is 'AbsolutePath' itself.
instance ReadPath (AbsolutePath crumb) crumb where
   absPath :: AbsolutePath crumb -> AbsolutePath crumb
   absPath :: AbsolutePath crumb -> AbsolutePath crumb
absPath = AbsolutePath crumb -> AbsolutePath crumb
forall a. a -> a
id
   {-# INLINE absPath #-}

-------------------------------------------------------------------------------

safehead :: [a] -> Maybe a
safehead :: [a] -> Maybe a
safehead []    = Maybe a
forall a. Maybe a
Nothing
safehead (a
a:[a]
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
{-# INLINE safehead #-}

-------------------------------------------------------------------------------