{-# LANGUAGE NamedFieldPuns #-}
module Zipper (
      Tree(..)
    , Zipper(..)
    , at
    , parse
    , up
  ) where

newtype Tree = Tree {
    children :: [(String, Tree)]
  }

data Context = Top | Context {
      before :: Tree
    , after :: Tree
    , line :: String
    , above :: Context
  }

data Zipper = Zipper {
      context :: Context
    , focus :: Tree
  }

at :: Int -> Zipper -> Zipper
at k (Zipper {context, focus}) =
  let (beforeSubTrees, (line, newFocus), afterSubTrees) = openLines k ([], subTrees) in
  Zipper {
        context = Context {
              before = Tree beforeSubTrees
            , after = Tree afterSubTrees
            , line
            , above = context
          }
      , focus = newFocus
    }
  where
    subTrees = children focus
    openLines 0 (left, []) = (drop 1 left, head left, [])
    openLines 0 (left, (center:right)) = (left, center, right)
    openLines _ (left, []) = openLines 0 (left, [])
    openLines n (left, (center:right)) = openLines (n-1) (center:left, right)

insert :: String -> Zipper -> Zipper
insert newLine z@(Zipper {context = Top}) = plug newLine z
insert newLine (Zipper {context, focus}) = Zipper {
      context = Context {
            before = Tree ((line context, focus):(children $ before context))
          , after = after context
          , line = newLine
          , above = above context
        }
    , focus = Tree []
  }

parse :: String -> Zipper
parse = zipUp . fst . foldl getStructure (Zipper Top $ Tree [], 0) . lines
  where
    getStructure (zipper, depth) line =
      let (indent, content) = span (== ' ') line in
      let n = depth - length indent in
      if n < 0
      then (plug content zipper, length indent)
      else (insert content (funPower n up zipper), length indent)
    funPower 0 _ x = x
    funPower n f x = funPower (n-1) f $ f x

plug :: String -> Zipper -> Zipper
plug line (Zipper {context}) = Zipper {
      context = Context {
            before = Tree []
          , after = Tree []
          , line
          , above = context
        }
    , focus = Tree []
  }

up :: Zipper -> Zipper
up z@(Zipper {context = Top}) = z
up (Zipper {context = Context {before, after, line, above}, focus}) = Zipper {
      context = above
    , focus = Tree (reverse (children before) ++ ((line, focus) : children after))
  }

zipUp :: Zipper -> Zipper
zipUp z@(Zipper {context = Top}) = z
zipUp z = zipUp (up z)