import Data.Tree (Tree(..), foldTree)
import qualified Data.Text.IO as T
import qualified Data.Text as T
import qualified Data.List as L
import Data.Bifunctor (first)
import Data.Ord (comparing)
import Data.Char (isSpace)




sortedOutline :: (Tree T.Text -> Tree T.Text -> Ordering)
              -> T.Text
              -> Either T.Text T.Text
sortedOutline cmp outlineText =
  let xs = T.lines outlineText
  in consistentIndentUnit (nonZeroIndents xs) >>=
     \indentUnit ->
        let forest = forestFromLineIndents $ indentLevelsFromLines xs
            sortedForest =
              subForest $
              foldTree (\x xs -> Node x (L.sortBy cmp xs)) (Node "" forest)
        in Right $ outlineFromForest indentUnit sortedForest




main :: IO ()
main =
  mapM_ T.putStrLn $
  concat $
  [ \(comparatorLabel, cmp) ->
       (\kv ->
           let section = headedSection (fst kv) comparatorLabel
           in (either (section . (" -> " <>)) section . sortedOutline cmp . snd)
                kv) <$>
       [ ("Four-spaced", spacedOutline)
       , ("Tabbed", tabbedOutline)
       , ("First unknown type", confusedOutline)
       , ("Second unknown type", raggedOutline)
       ]
  ] <*>
  [("(A -> Z)", comparing rootLabel), ("(Z -> A)", flip (comparing rootLabel))]

headedSection :: T.Text -> T.Text -> T.Text -> T.Text
headedSection outlineType comparatorName x =
  T.concat ["\n", outlineType, " ", comparatorName, ":\n\n", x]

spacedOutline, tabbedOutline, confusedOutline, raggedOutline :: T.Text
spacedOutline =
  "zeta\n\
    \    beta\n\
    \    gamma\n\
    \        lambda\n\
    \        kappa\n\
    \        mu\n\
    \    delta\n\
    \alpha\n\
    \    theta\n\
    \    iota\n\
    \    epsilon"

tabbedOutline =
  "zeta\n\
    \\tbeta\n\
    \\tgamma\n\
    \\t\tlambda\n\
    \\t\tkappa\n\
    \\t\tmu\n\
    \\tdelta\n\
    \alpha\n\
    \\ttheta\n\
    \\tiota\n\
    \\tepsilon"

confusedOutline =
  "zeta\n\
    \    beta\n\
    \  gamma\n\
    \        lambda\n\
    \  \t    kappa\n\
    \        mu\n\
    \    delta\n\
    \alpha\n\
    \    theta\n\
    \    iota\n\
    \    epsilon"

raggedOutline =
  "zeta\n\
    \    beta\n\
    \   gamma\n\
    \        lambda\n\
    \         kappa\n\
    \        mu\n\
    \    delta\n\
    \alpha\n\
    \    theta\n\
    \    iota\n\
    \    epsilon"




forestFromLineIndents :: [(Int, T.Text)] -> [Tree T.Text]
forestFromLineIndents = go
  where
    go [] = []
    go ((n, s):xs) = Node s (go subOutline): go rest
      where
        (subOutline, rest) = span ((n <) . fst) xs

indentLevelsFromLines :: [T.Text] -> [(Int, T.Text)]
indentLevelsFromLines xs = first (`div` indentUnit) <$> pairs
  where
    pairs = first T.length . T.span isSpace <$> xs
    indentUnit = maybe 1 fst (L.find ((0 <) . fst) pairs)

outlineFromForest :: T.Text -> [Tree T.Text] -> T.Text
outlineFromForest tabString forest = T.unlines $ forest >>= go ""
  where
    go indent node =
      indent <> rootLabel node:
      (subForest node >>= go (T.append tabString indent))


consistentIndentUnit :: [T.Text] -> Either T.Text T.Text
consistentIndentUnit prefixes = minimumIndent prefixes >>= checked prefixes
  where
    checked xs indentUnit
      | all ((0 ==) . (`rem` unitLength) . T.length) xs = Right indentUnit
      | otherwise =
        Left
          ("Inconsistent indent depths: " <>
           T.pack (show (T.length <$> prefixes)))
      where
        unitLength = T.length indentUnit

minimumIndent :: [T.Text] -> Either T.Text T.Text
minimumIndent prefixes = go $ T.foldr newChar "" $ T.concat prefixes
  where
    newChar c seen
      | c `L.elem` seen = seen
      | otherwise = c: seen
    go cs
      | 1 < length cs =
        Left $ "Mixed indent characters used: " <> T.pack (show cs)
      | otherwise = Right $ L.minimumBy (comparing T.length) prefixes

nonZeroIndents :: [T.Text] -> [T.Text]
nonZeroIndents textLines =
  [ s
  | x <- textLines 
  , s <- [T.takeWhile isSpace x] 
  , 0 /= T.length s ]