-- |Nested list (i.e. n-ary tree) support for CGI applications.  This
-- includes a naming convention for elements of the tree, functions to
-- parse the name into a path through the tree to an element.  Also
-- included are functions to add, delete, move, and modify elements
-- referred to by the TreePath returned by the parser, and so on.
module TreePath
    ( -- * The TreePath type
      TreePath(..)
    , Position
    , pos1
    , posList
    , nth
    -- * Creating TreePaths
    , rootPath
    , parsePath
    , parsePosition	-- Rename: parsePath'?
    -- * TreePath -> String
    , (+-+)
    , showId
    -- * List operators
    , moveUp
    , moveDown
    , deleteElt
    , extractElt
    , moveElt
    , shiftElt
    , insertElt
    , updateElt0
    , updateElt1
    , updateEltM
    ) where

import Data.List
import Text.Regex

-- |A path through a tree, root first
data TreePath = TreePath [Position] deriving (Eq, Ord, Show)

-- |A Position is a 1-based list index.  Once we switch to zero based
-- indexes this will become just an Int.
newtype Position = Pos Int deriving (Eq, Ord, Show)

-- The position of the first element of a list (equals head posList)
pos1 :: Position
pos1 = Pos 1

posList :: [Position]
posList = map Pos [1..]

nth :: [a] -> Position -> a
nth xs (Pos x) =
    if x < 1 || x > length xs
    then error ("deleteElem: Attempt to access " ++ show x ++ "th element of " ++ show (length xs))
    else xs !! (x - 1)

showId :: TreePath -> String
showId (TreePath pos) = concat (intersperse [separator] (map (\ (Pos p) -> "i" ++ show p) pos))

-- |This is the character used to connect elements of the prefix.  It
-- is important not to use '.' as the separating character so that the
-- whole thing looks like a single identifier to Javascript.
separator :: Char
separator = '_'

(+-+) :: String -> String -> String
(+-+) a b = a ++ [separator] ++ b

rootPath :: TreePath
rootPath = TreePath [pos1]

-- Parse an element identifier string
parsePath :: String -> TreePath
parsePath "" = TreePath []
parsePath s =
    TreePath (parse s)
    where
      parse s =
          case matchRegexAll re s of
            Just (_, _, next, [_, index]) ->
                Pos (read index) : 
                    if next == ""
                    then []
                    else if head next == separator
                         then parse (tail next)
                         else error $ "Invalid element id: " ++ show s
            _ -> error $ "Invalid element id: " ++ s
      re = mkRegex "^([^0-9]+)([0-9]+)"

-- |Parse a nested list position, returning the result with the unused
-- portion of the string.
parsePosition :: String -> (TreePath, String)
parsePosition s =
    parse [] s
    where
      parse p s =
          case matchRegexAll re s of
            Just (_, _, next, [_, index]) ->
                parse (p ++ [Pos (read index)]) next
            _ -> (TreePath p, s)
      re = mkRegex ("^([^0-9]+)([0-9]+)[" ++ [separator] ++ "]")

moveUp :: Position -> [a] -> [a]
moveUp (Pos n) elems = shiftElt (Pos n) (Pos (n - 1)) elems

moveDown :: Position -> [a] -> [a]
moveDown (Pos n) elems = shiftElt (Pos n) (Pos (n + 1)) elems

deleteElt :: Position -> [a] -> [a]
deleteElt n elems = snd (extractElt n elems)

-- Return an element, the first element is element 0
extractElt :: Position -> [a] -> (a, [a])
extractElt (Pos n) elems =
    case splitAt' (n - 1) elems of
      (head, elt : tail) -> (elt, head ++ tail)
      _ -> error "extractElt"

-- Move an element from one list to another.
moveElt :: Position -> [a] -> Position -> [a] -> ([a], [a])
moveElt xi xs yi ys =
    let (x, xs') = extractElt xi xs in
    (xs', insertElt yi x ys)

-- Move element n to position m, leaving the other elements order
-- unchanged but shifting them left or right as necessary.
shiftElt :: Position -> Position -> [a] -> [a]
shiftElt i1 (Pos i2) xs =
    let (x, xs') = extractElt i1 xs in
    insertElt (Pos (i2 - 1)) x xs'

-- Insert at position zero to add an element at the beginning of the
-- list.
insertElt :: Position -> a -> [a] -> [a]
insertElt (Pos n) new elems =
    case splitAt' n elems of
      (head, tail) -> head ++ [new] ++ tail

-- Modify the n'th element of a list.
updateElt1 :: Position -> (a -> a) -> [a] -> [a]
updateElt1 (Pos index) f xs =
    case splitAt' (index - 1) xs of
      (_, []) -> error $ "Can't update element " ++ show index ++ " of a list of length " ++ show (length xs) ++ "."
      (a, x : b) -> a ++ [f x] ++ b

-- Modify the n'th element of a list.
updateElt0 :: Int -> (a -> a) -> [a] -> [a]
updateElt0 index f xs =
    case splitAt' index xs of
      (_, []) -> error $ "Can't update element " ++ show index ++ " of a list of length " ++ show (length xs) ++ "."
      (a, x : b) -> a ++ [f x] ++ b

splitAt' n l | n >= 0 && n <= length l = splitAt n l
splitAt' n l = error $ "splitAt: Invalid argument " ++ show n ++ " of " ++ show (length l)

-- Monadic version of updateElt
updateEltM :: Monad m => Position -> (a -> m a) -> [a] -> m [a]
updateEltM (Pos index) f xs =
    case splitAt (index - 1) xs of
      (_, []) -> error $ ("Can't update element " ++ show index ++
                          " of a list of length " ++ show (length xs) ++ ".")
      (a, x : b) -> f x >>= \ y -> return $ a ++ [y] ++ b