ke.hs

--module MyZipper 
--    ( File()
--    , Position
--    , up
--    , downAtLeft
--    , downAtRight
--    , left
--    , right
--    , comeIn
--    ) 
--where

{-# LANGUAGE TemplateHaskell, Rank2Types #-}

import           Data.Sequence   (Seq, ViewL(..), ViewR(..), (<|), (|>), (><))
import qualified Data.Sequence as Seq
import           Data.Sequence.Lens

import           Data.Monoid

import           Control.Applicative
import           Control.Monad
import           Control.Monad.State

import           Control.Lens hiding ((<|), (|>))

data File 
    = Leaf
        { _nodeName :: String
        , _content  :: Seq String } 

    | Branch 
        { _nodeName :: String
        , _files    :: Seq File } 

    deriving (Show)

$(makeLenses ''File)
$(makePrisms ''File)

data Focus
    = OnFile     { _node  ::     File }
    | OnFileList { _nodes :: Seq File }
    | OnLine     { _line  ::     String }
    | OnLineList { _lines :: Seq String }

    deriving (Show)

$(makeLenses ''Focus)
$(makePrisms ''Focus)

data Position 
    = Position 
        { _focus   :: Focus
        , _path    :: Breadcrumbs
        , _version :: Integer }

    deriving Show

type Breadcrumbs = [Breadcrumb]

data Breadcrumb
    = InFileName
        { theContent  :: Seq String }

    | AtFileContent
        { theName     :: String }

    | InFileContent 
        { linesBefore :: Seq String
        , linesAfter  :: Seq String }

    | InBranchName  
        { theFiles    :: Seq File }

    | AtFileList
        { theName     :: String }

    | InFileList    
        { filesBefore :: Seq File
        , filesAfter  :: Seq File }

    deriving Show

$(makeLenses ''Breadcrumb)
$(makePrisms ''Breadcrumb)

$(makeLenses ''Position)
$(makePrisms ''Position)

getFile     :: Position -> Maybe File
getLine     :: Position -> Maybe String
getFileList :: Position -> Maybe (Seq File)
getLineList :: Position -> Maybe (Seq String)

getFile     pos = pos^? focus._OnFile
getLine     pos = pos^? focus._OnLine
getFileList pos = pos^? focus._OnFileList
getLineList pos = pos^? focus._OnLineList

modifyFile     ::     (File   ->     File)   -> (Position -> Maybe Position)
modifyLine     ::     (String ->     String) -> (Position -> Maybe Position)
modifyFileList :: (Seq File   -> Seq File)   -> (Position -> Maybe Position)
modifyLineList :: (Seq String -> Seq String) -> (Position -> Maybe Position)

modifyFile     f = (focus._OnFile) `failover` f
modifyLine     f = (focus._OnLine) `failover` f
modifyFileList f = (focus._OnFileList) `failover` f
modifyLineList f = (focus._OnLineList) `failover` f

enter :: Monad m => File -> StateT Position m a -> m a
enter root action = do
    action `evalStateT` Position (OnFile root) [] 0

comeOut :: Monad m => StateT Position m File
comeOut = do
    farthest up
    OnFile root <- retrieve focus
    return root

type Transition = Monad m => StateT Position m ()

up :: Transition
up = do
    inCaseOf (path._NotEmpty) $ \(top, rest) -> do
        incrementVersion

        path .= rest

        f <- retrieve focus

        case (f, top) of
            (OnLine line, InFileName content) ->
                focus .= OnFile (Leaf line content)

            (OnLine line, InFileContent before after) -> do
                let content = before <> one line <> after

                focus .= OnLineList content

            (OnLine line, InBranchName files) ->
                focus .= OnFile (Branch line files)

            (OnLineList list, AtFileContent name) ->
                focus .= OnFile (Leaf name list)

            _ ->
                dumpErrorneousState "up"

farthest :: Transition -> Transition
farthest move = do
    was <- retrieve version
    move
    became <- retrieve version

    when (was /= became) $
        farthest move

incrementVersion :: Transition
incrementVersion = version += 1

retrieve :: MonadState s m => Getting a s a -> m a
retrieve = use

viewedAs = ($)

inCaseOf prism action = do
    x <- get

    inCaseOf' x prism action

inCaseOf' x prism action = do
    maybe (return ()) action (x^? prism)

_NotEmpty = _Cons

one = Seq.singleton

dumpErrorneousState locus = do
    get >>= fail . ((locus ++ ": invalid state:") ++) . show

--up position @ (focus, stack) = case focus of
--    OnLine line -> case stack of
--        InFileName content : rest ->
--            return (OnFile (Leaf line content), rest)

--        InFileContent before after : rest -> do
            
--            let content = before <> one line <> after
            
--            return (OnLineList content, rest)

--        InBranchName files : rest ->
--            return (OnFile (Branch line files), rest)

--        _  -> die ["up: broken position -", show position]

--    OnLineList list -> case stack of
--        AtFileContent name : rest ->
--            return (OnFile (Leaf name list), rest)

--        _  -> die ["up: broken position -", show position]


--    OnFile file -> case stack of
--        InFileList before after : rest -> do
--            let list = before <> one file <> after
--            return (OnFileList list, rest)

--        [] -> complain ["up: at root: -",   show position]
--        _  -> die ["up: broken position -", show position]

--    OnFileList list -> case stack of
--        AtFileList name : rest ->
--            return (OnFile (Branch name list), rest)

--        _  -> die ["up: broken position -", show position]

downAtLeft :: Transition
downAtLeft = do
    incrementVersion

    f <- retrieve focus

    case f of
        OnFile (Leaf name content) -> do
            focus .= OnLine name
            path ++= [InFileName content]

        OnFile (Branch name files) -> do
            focus .= OnLine name
            path ++= [InBranchName files]

        OnFileList list ->
            inCaseOf' list _HasLeftElement $ \(left, rest) -> do
                focus .= OnFile left
                path ++= [InFileList Seq.empty rest]

        OnLineList list ->
            inCaseOf' list _HasLeftElement $ \(left, rest) -> do
                focus .= OnLine left
                path ++= [InFileContent Seq.empty rest]

_HasLeftElement :: Simple Traversal (Seq a) (a, Seq a)
_HasLeftElement f list = case Seq.viewl list of
    left :< rights -> uncurry (<|) <$> f (left, rights)
    EmptyL         -> pure Seq.empty

_HasRightElement :: Simple Traversal (Seq a) (Seq a, a)
_HasRightElement f list = case Seq.viewr list of
    lefts :> right -> uncurry (|>) <$> f (lefts, right)
    EmptyR         -> pure Seq.empty

lens ++= x = lens %= (x ++)

--downAtLeft :: Transition
--downAtLeft position @ (focus, stack) = case focus of
--    OnFile (Leaf name content) ->
--        return (OnLine name, InFileName content : stack)

--    OnFile (Branch name files) ->
--        return (OnLine name, InBranchName files : stack)

--    OnFileList list -> case Seq.viewl list of
--        first :< rest ->
--            return (OnFile first, InFileList Seq.empty rest : stack)

--        EmptyL ->
--            complain ["down: no wai"]

--    OnLineList list -> case Seq.viewl list of
--        first :< rest ->
--            return (OnLine first, InFileContent Seq.empty rest : stack)

--        EmptyL ->
--            complain ["down: no wai"]

--    _ ->
--        complain ["down: no wai"]

downAtRight :: Transition
downAtRight = do
    incrementVersion

    f <- retrieve focus

    case f of
        OnFile (Leaf name content) -> do
            focus .=  OnLineList content
            path ++= [AtFileContent name]

        OnFile (Branch name content) -> do
            focus .=  OnFileList content
            path ++= [AtFileList name]

        OnFileList list -> do
            inCaseOf' list _HasRightElement $ \(init, last) -> do
                focus .=  OnFile last
                path ++= [InFileList init Seq.empty]

        OnLineList list -> do
            inCaseOf' list _HasRightElement $ \(init, last) -> do
                focus .=  OnLine last
                path ++= [InFileContent init Seq.empty]

--downAtRight :: Transition
--downAtRight position @ (focus, stack) = case focus of
--    OnFile (Leaf name content) ->
--        return (OnLineList content, AtFileContent name : stack)

--    OnFile (Branch name files) ->
--        return (OnFileList files, AtFileList name : stack)

--    OnFileList list -> case Seq.viewr list of
--        init :> last ->
--            return (OnFile last, InFileList init Seq.empty : stack)

--        EmptyR ->
--            complain ["down: no wai"]

--    OnLineList list -> case Seq.viewr list of
--        init :> last ->
--            return (OnLine last, InFileContent init Seq.empty : stack)

--        EmptyR ->
--            complain ["down: no wai"]

--    _ ->
--        complain ["down: no wai"]

left :: Transition
left = do
    inCaseOf (path._NotEmpty) $ \(top, rest) -> do
        f <- retrieve focus

        case (f, top) of
            (OnFile file, InFileList before after) ->
                inCaseOf' before _HasRightElement $ \(init, last) -> do
                    incrementVersion

                    focus .=  OnFile last
                    path ++= [InFileList init (file <| after)]

            (OnLine _, InFileName   _) -> skip
            (OnLine _, InBranchName _) -> skip

            (OnLine line, InFileContent before after) ->
                inCaseOf' before _HasRightElement $ \(init, last) -> do
                    incrementVersion

                    focus .=  OnLine last
                    path ++= [InFileContent init (line <| after)]

            (OnFileList list, AtFileList name) -> do
                incrementVersion
                
                focus .=  OnLine name
                path ++= [InBranchName list]

            (OnLineList list, AtFileContent name) -> do
                incrementVersion
                
                focus .=  OnLine name
                path ++= [InFileName list]

skip :: Monad m => m ()
skip = return ()

--left :: Transition
--left position @ (focus, stack) = case focus of
--    OnFile file -> case stack of
--        InFileList before after : rest -> case Seq.viewr before of
--            init :> last ->
--                return (OnFile last, InFileList init (file <| after) : rest)

--            EmptyR ->
--                complain ["left: no wai"]

--        _  -> die ["left: broken position -", show position]

--    OnLine line -> case stack of
--        InFileName   _ : rest -> complain ["left: no wai"]
--        InBranchName _ : rest -> complain ["left: no wai"]
--        InFileContent before after : rest -> case Seq.viewr before of
--            init :> last ->
--                return (OnLine last, InFileContent init (line <| after) : rest)

--            EmptyR ->
--                complain ["left: no wai"]

--        _  -> die ["left: broken position -", show position]

--    OnFileList list -> case stack of
--        AtFileList name : stack ->
--            return (OnLine name, InBranchName list : stack)

--        _  -> die ["left: broken position -", show position]

--    OnLineList list -> case stack of
--        AtFileContent name : stack ->
--            return (OnLine name, InFileName list : stack)

--        _  -> die ["left: broken position -", show position]

right :: Transition
right = do
    f <- retrieve focus

    inCaseOf (path._NotEmpty) $ \(top, rest) -> do
        case (f, top) of
            (OnLine line, InFileName content) -> do
                incrementVersion

                focus .=  OnLineList content
                path ++= [AtFileContent line]

            (OnLine line, InBranchName content) -> do
                incrementVersion

                focus .=  OnFileList content
                path ++= [AtFileList line]

            (OnLine line, InFileContent before after) -> 
                inCaseOf' after _HasLeftElement $ \(next, after) -> do
                    incrementVersion

                    focus .=  OnLine next
                    path ++= [InFileContent (before |> line) after]

            (OnFile file, InFileList before after) ->
                inCaseOf' after _HasLeftElement $ \(next, after) -> do
                    incrementVersion

                    focus .=  OnFile next
                    path ++= [InFileList (before |> file) after]

            (OnLineList _, _) -> skip
            (OnFileList _, _) -> skip

--right :: Transition
--right position @ (focus, stack) = case focus of
--    OnLine line -> case stack of
--        InFileName content : stack ->
--            return (OnLineList content, AtFileContent line : stack)

--        InBranchName content : stack ->
--            return (OnFileList content, AtFileList line : stack)

--        InFileContent before after : stack -> case Seq.viewl after of
--            next :< after ->
--                return 
--                    ( OnLine next
--                    , InFileContent (before |> line) after 
--                    : stack
--                    )

--            EmptyL ->
--                fail "right: no wai"

--        [] ->
--            fail "right: no wai"

--        _  -> die ["right: broken position -", show position]

--    OnFile file -> case stack of
--        InFileList before after : stack -> case Seq.viewl after of
--            next :< after ->
--                return 
--                    ( OnFile next
--                    , InFileList (before |> file) after 
--                    : stack
--                    )

--            EmptyL ->
--                fail "right: no wai"

--        [] ->
--            fail "right: no wai"

--        _  -> die ["right: broken position -", show position]


--    _  -> complain ["right: no wai"]

x `untilCan` y = do
    was <- retrieve version
    y
    became <- retrieve version

    when (was == became) $ do
        was <- retrieve version
        x
        became <- retrieve version

        when (was /= became) $
            x `untilCan` y


--nextFile :: Transition
--nextFile position @ (focus, stack) = case focus of
--    OnFile (Leaf _ _) ->
--        position & up `untilCan` right

--    OnFile (Branch _ _) ->
--        position
--            & firstSuccessful
--                [ downAtRight >=> downAtLeft
--                , up >=> right
--                , up >=> up >=> nextFile
--                ]

--nextLine :: Transition
--nextLine position @ (focus, stack) = case focus of
--    OnLine _ -> position & case stack of
--        InFileName _ : _ -> 
--            firstSuccessful 
--                [ right >=> downAtLeft
--                , up >=> nextFile >=> downAtLeft
--                ]

--        InBranchName _ : _ ->
--            up >=> nextFile >=> downAtLeft

--        InFileContent _ _ : _ ->
--            firstSuccessful [right, up >=> up >=> nextFile >=> downAtLeft]

--untilCan :: Transition -> Transition -> Transition
--(x `untilCan` y) position
--    | Just it <- y position
--        = Just it
--    | Just new <- x position
--        = (x `untilCan` y) new
--    | otherwise
--        = Nothing

--farthest :: Transition -> Transition
--farthest transition position = case transition position of
--    Just it -> farthest transition it
--    Nothing -> return position

--trail :: Transition -> Position -> Seq Focus
--trail transition position @ (focus, stack) =
--    focus <| Seq.unfoldr 
--        (\pos -> do 
--            r @ (x, _) <- transition pos
--            return (x, r))
--        position

--firstSuccessful :: [Transition] -> Transition
--firstSuccessful []          position = fail "firstSuccessful: no wai"
--firstSuccessful (op : list) position
--    | Just it <- op position
--        = Just it

--    | otherwise
--        = firstSuccessful list position

--test = comeIn $ dir "/"
--    [ dir "user"
--        [ dir "vasua"
--            [ file "a" "hello funcking world"
--            , file "e" ""
--            ]
--        ]
--    , file "b" "hi there"
--    ]

--dir  name = Branch name . s
--file name = Leaf   name . s . words

--one = Seq.singleton
--s   = Seq.fromList

--die      = error . unwords
--complain = fail  . unwords