module System.Directory.Layout.Internal
( Node(..), Layout
) where
import Control.Applicative (Applicative(..), (<$>))
import Data.Foldable (Foldable(..))
import Data.Traversable (Traversable(..), fmapDefault, foldMapDefault)
import Data.Monoid (Monoid(..))
import Unsafe.Coerce (unsafeCoerce)
import Data.Default (Default(..))
import Data.Functor.Apply (Apply(..))
import Data.Functor.Bind (Bind(..))
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
type Layout = Node ()
data Node a =
E !a
| T !Text !a
| F !FilePath !Layout !(Node a)
| D !FilePath !Layout !(Node a)
deriving (Show, Read, Eq, Ord)
compareFilePath :: Node a -> Node b -> Ordering
compareFilePath (E _) (E _) = EQ
compareFilePath (E _) _ = LT
compareFilePath _ (E _) = GT
compareFilePath (T _ _) (T _ _) = EQ
compareFilePath (T _ _) _ = LT
compareFilePath _ (T _ _) = GT
compareFilePath (F fp _ _) (F fp' _ _) = compare fp fp'
compareFilePath (F _ _ _) _ = LT
compareFilePath _ (F _ _ _) = GT
compareFilePath (D fp _ _) (D fp' _ _) = compare fp fp'
instance Default a => Default (Node a) where
def = E def
instance Semigroup (Node a) where
(<>) = (>>)
instance Default a => Monoid (Node a) where
mempty = def
mappend = (<>)
instance Functor Node where
fmap = fmapDefault
instance Apply Node where
f <.> x =
f >>- \f' ->
x >>- \x' ->
pure (f' x')
instance Applicative Node where
pure = E
(<*>) = (<.>)
instance Bind Node where
E x >>- f = f x
T _ x >>- f = f x
n@(F _ _ x) >>- f = n >>* (x >>- f)
n@(D _ _ x) >>- f = n >>* (x >>- f)
(>>*) :: Node a -> Node b -> Node b
a >>* b =
case compareFilePath a b of
GT -> case b of
E _ -> unsafeCoerce a
T _ _ -> unsafeCoerce a
F f t l -> F f t (a >>* l)
D f l l' -> D f l (a >>* l')
_ -> case a of
E _ -> b
T _ _ -> b
F f t _ -> F f t b
D f l _ -> D f l b
instance Monad Node where
return = pure
a >> b =
case compareFilePath a b of
GT -> case b of
E _ -> unsafeCoerce a
T _ _ -> unsafeCoerce a
F f t l -> F f t (a >> l)
D f l l' -> D f l (a >> l')
_ -> case a of
E _ -> b
T _ _ -> b
F f t l -> F f t (l >> b)
D f l l' -> D f l (l' >> b)
(>>=) = (>>-)
instance Foldable Node where
foldMap = foldMapDefault
instance Traversable Node where
traverse f (E x) = E <$> f x
traverse f (T t x) = T t <$> f x
traverse f (F fp t x) = F fp t <$> traverse f x
traverse f (D fp x y) = D fp x <$> traverse f y