{-# 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(..),
    -- ** Modification
    drop,
    -- ** Destruction
    fromStrictList,foldl',
    -- * Strict trees and forests
    StrictTree,StrictForest,
    -- ** Construction
    ToStrictTree(..),ToStrictForest(..),
    -- ** 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)

-- Strict lists (in both the head and tail)
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 = 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)


-- copied from Data.List
foldl' ::  (r -> a -> r) -> r -> StrictList a -> r
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

        

drop ::  (Integral a) => a -> StrictList t -> StrictList t
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



-- | 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


 



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)