{-# LANGUAGE PatternGuards #-}
-- Quickly hacked program to fixup Data.Collections.Properties, comments and property names.

-- This implementation is highly insatisfactory, because it basically doesn't understand anything to
-- haskell syntax and still modifies programs.
-- However, at the time of writing, there exists no haskell parsing library that supports both:
--  * parsing and retaining comments;
--  * pretty printing with the comments retained.
-- Therefore, I try to get with it by looking at indentation and a few key characters.

import Data.Tree
import Data.List
import Data.Char

indentationLevel (' ':xs) = 1 + indentationLevel xs
indentationLevel ('\t':xs) = 8 + indentationLevel xs
indentationLevel _ = 0

mkForest = map mkTree . items

mkTree (x:xs) = Node x (mkForest xs)

items [] = []
items (x:xs) = (x:l) : items r
    where (l,r) = span (subordinatedTo x) xs

subordinatedTo s1 s2 | commentLine s1 = False
                     | commentLine s2 = True
                     | otherwise = indentationLevel s2 > indentationLevel s1

emptyLine = all isSpace

nullNode (Node lab subs) = emptyLine lab && all nullNode subs

commentLine [] = True
commentLine ('-':'-':_) = True
commentLine (c:cs) = isSpace c && commentLine cs

dropComments = concatMap dropComment'

dropComment' x = [n,Node (unlines $ filter (not . emptyLine) $ cmts) []]
    where (n,cmts) = dropComment x

dropComment :: Tree String -> (Tree String, [String])
dropComment (Node l f) = (Node l f', rest ++ concatMap flatten (reverse f1))
    where (f1,f2) = span commentNode (reverse f)
          (rest, f') = if null f2 
               then ([], [])
               else let (n',rest) = dropComment (head f2) in (rest, reverse (n':tail f2))

commentNode = commentLine . rootLabel

emptyNode = Node [] []

groupFcts (n0:n1@(Node s1 f1):n2@(Node s2 f2):ns) 
    | isTyp s1, isDef s2, name n1 == name n2 = (name n1,
                                                if commentNode n0 then n0 else emptyNode,
                                                n1,n2) : groupFcts (emptyNode:ns)
groupFcts (n1:ns) = ("",emptyNode,emptyNode,n1) : groupFcts ns
groupFcts [] = []

isTyp = any ("::" `isPrefixOf`) . tails

isDef = elem '='

def t = map (drop lhs) $ filter (not . commentLine) $ text
    where lhs = 1 + length (takeWhile (/='=') (head text))
          text = flatten t

name = takeWhile (not . isSpace) . trim . rootLabel

trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse

escape = concatMap e
    where e c = if c `elem` "/\\\'`@<>*-" then ['\\',c] else [c]

subTrees t = t : concatMap subTrees (subForest t)

type Def = (String, Tree String, Tree String, Tree String)


-- TODO: quote the identifiers in definitions so they get cross-referenced.

fixDefinition :: Def -> Def
fixDefinition fct@(x, cmt, typ, n@(Node lab subnodes)) 
    | "properties" `isSuffixOf` name n = (x, Node cmt' [], typ, Node lab' subnodes)
    | otherwise = fct
    where lab' = takeWhile (/= '=') lab ++ "= [" ++ (concat $ intersperse ", " $ map propCouple propNames) ++ "]"
          props = filter (("prop_" `isPrefixOf`) . name) (concatMap subTrees subnodes)
          propNames = map name props
          propCouple p = "(property " ++ p ++ "," ++ show (dropPrefix p) ++ ")"
          propComment p = ["--", "-- [/" ++ dropPrefix (name p) ++ "/]", "--"] ++ map ("--      > " ++) (def p) 
          -- text@" ++ escape (def p) ++ "@"
          cmt' = unlines $ ("-- | " ++ name n ++ " returns the following properties: ") : concatMap propComment props

dropPrefix = tail . dropWhile (/= '_')          
          
fctForest (name, cmts, typ, def) = [cmts,typ,def,Node "" []]

cleanBlanks ls = map fst $ filter (not . bothEmpty) $ zip ls ("":ls)
    where bothEmpty (a,b) = emptyLine a && emptyLine b

cleanBlanks' ls = map fst $ filter (not . bothEmpty) $ zip ls (' ':ls)
    where bothEmpty (a,b) = isSpace a && isSpace b


main = do src <- getContents
          let forest = filter (not . nullNode) $ dropComments $ mkForest $ lines src
          --putStr $ drawForest forest
          --mapM_ putStrLn $ map showGrp $ groupFcts forest
          let forest' = concat $ map fctForest $ map fixDefinition $ groupFcts $ forest
          mapM_ putStrLn $ cleanBlanks $ concatMap flatten forest'

showGrp (n,cmts,_,t) = n ++ "--->\n" ++ unlines (flatten cmts) ++ "\n" ++ drawTree t