{-# LANGUAGE DeriveDataTypeable,DeriveFunctor,BangPatterns,DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable,NoMonomorphismRestriction, FlexibleContexts,FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS -Wall #-}
-- | Remark: the heavy use of strictness here is for correctly catching exceptions, not for performance reasons
module DataTreeView.StrictTypes(
    module Data.Tree,
    module Data.Monoid,
    -- * Strict lists
    StrictList,
    -- ** Construction
    ToStrictList(..),
    -- ** Destruction
    fromStrictList,
    -- * Strict trees and forests
    StrictTree,StrictForest,
    -- ** Construction
    ToStrictTree(..),ToStrictForest(..),
    -- ** Modification
    modifyValue, modifyChildren,
    -- ** Destruction
    nodeValue,nodeChildren,fromStrictTree,fromStrictForest) where 
import Data.Typeable
import Data.Monoid
import Prelude hiding(drop)
import Data.Tree
import Data.Foldable(Foldable)
import Data.Traversable(Traversable)
import Data.Data
import Data.List(unfoldr)
import Data.ListLike

-- | Strict lists (in both the head and tail)
--
-- Note: Most operations for this type are provided via the 'ListLike' instance, but 'ListLike' is not reexported here.
data StrictList a = SNil | SCons !a !(StrictList a)  
    deriving(Show,Typeable,Data,Functor,Foldable,Traversable)

class ToStrictList x a where
    strictList :: x -> StrictList a

-- | Singleton
instance ToStrictList a a where
    strictList x = SCons x SNil

-- | From lazy list
instance ToStrictList [a] a where
    strictList = Prelude.foldr SCons SNil

-- | Cons
instance ToStrictList x a => ToStrictList (a, x) a where
    strictList (a,x) = SCons a (strictList x)

-- | Identity
instance ToStrictList (StrictList a) a where
    strictList = id



fromStrictList ::  StrictList a -> [a]
fromStrictList = unfoldr f 
    where
        f SNil = Nothing
        f (SCons x xs) = Just (x,xs)



instance FoldableLL (StrictList a) a where
    -- copied from Data.List
    foldl' f z0 xs0 = lgo z0 xs0
        where lgo z SNil     = z
              lgo z (SCons x xs) = let z' = f z x in z' `seq` lgo z' xs

    foldl f z0 xs0 = lgo z0 xs0
        where lgo z SNil = z
              lgo z (SCons x xs) = lgo (f z x) xs

    foldr f z0 = go
        where go SNil = z0
              go (SCons x xs) = f x (go xs)


instance ListLike (StrictList a) a where
    singleton = strictList

    head (SCons x _) = x
    head _ = error "`head' on empty StrictList"

    tail (SCons _ xs) = xs
    tail _ = error "`tail on empty StrictList"

    drop n xs | n < 0 = error "Strict.drop: n<0" 
            | otherwise = go n xs
        where
            go 0 xs' = xs'
            go n' (SCons _ xs'') = go (pred n') xs''
            go _ SNil = SNil


    null (SCons _ _) = False
    null SNil = True
    



-- | Empty list and appending
instance Monoid (StrictList a) where
    mempty = SNil
    mappend SNil !b = b
    mappend (SCons a1 a2) !b = SCons a1 (mappend a2 b)  

data StrictTree a = SNode !a !(StrictForest a) deriving(Show,Typeable,Data,Functor,Foldable,Traversable)  

type StrictForest a = StrictList (StrictTree a)

class ToStrictTree x a where
    strictTree :: x -> StrictTree a

-- | Leaf
instance ToStrictTree a a where
    strictTree = flip SNode SNil

-- | From lazy tree
instance ToStrictTree (Tree a) a where
    strictTree (Node a ts) = SNode a (strictForest ts :: StrictForest a)

-- | From node value and subforest
instance ToStrictForest y a => ToStrictTree (a, y) a where
    strictTree (a,y) = SNode a (strictForest y)

-- | Identity
instance ToStrictTree (StrictTree a) a where
    strictTree = id

class ToStrictForest y a where
    strictForest :: y -> StrictForest a

instance (ToStrictTree x a) => ToStrictForest [x] a where
    strictForest = strictList . fmap (strictTree :: x -> StrictTree a)

instance (ToStrictTree x a) => ToStrictForest (StrictList x) a where
    strictForest = strictList . fmap (strictTree :: x -> StrictTree a)

-- | Identity
instance ToStrictForest (StrictForest a) a where
    strictForest = id



nodeValue :: StrictTree a -> a
nodeValue (SNode a _) = a

nodeChildren :: StrictTree t -> [StrictTree t]
nodeChildren (SNode _ ts) = fromStrictList ts


-- | Note: this function is not recursive.
modifyValue :: StrictTree a -> (a -> a) -> StrictTree a
modifyValue (SNode a ts) f = SNode (f a) ts

-- | Note: this function is not recursive.
modifyChildren
  :: StrictTree a -> (StrictForest a -> StrictForest a) -> StrictTree a
modifyChildren (SNode a ts) f = SNode a (f ts)



fromStrictForest :: StrictForest a -> Forest a
fromStrictForest = fmap fromStrictTree . fromStrictList

fromStrictTree ::  StrictTree a -> Tree a
fromStrictTree = unfoldTree f
    where
        f (SNode a ts) = (a, fromStrictList ts)