module Derive.Generate(generate) where

import Language.Haskell.Exts
import Data.DeriveDSL
import Derive.Utils
import Control.Monad
import Data.Maybe
import System.FilePath
import System.Directory
import Data.Char
import Data.List


evil = words $ "TTypeable Uniplate"

-- generate extra information for each derivation
generate :: IO ()
generate = do
    xs <- getDirectoryContents "Data/Derive"
    xs <- return $ sort [x | x <- xs, takeExtension x == ".hs", x /= "All.hs", takeBaseName x `notElem` evil]
    lis <- mapM generateFile $ map ("Data/Derive" </>) xs
    let names = map dropExtension xs
        n = maximum $ map length names
    writeGenerated "Data/Derive/All.hs" $
        ["import Data.Derive." ++ x ++ replicate (4 + n - length x) ' ' ++ "as D" | x <- names] ++
        ["derivations :: [Derivation]"
        ,"derivations = [make" ++ concat (intersperse ",make" names) ++ "]"]
    writeGenerated "derive.htm" $ ["-->"] ++ lis ++ ["<!--"]
    writeGenerated "derive.cabal" $ map ("        Data.Derive."++) names


-- return the Documentation string
generateFile :: FilePath -> IO String
generateFile file = do
    let name = takeBaseName file
    putStrLn $ "Generating " ++ name
    src <- readSrc file
    when (isJust $ srcExample src) $ do
        let dsl = fromMaybe (error $ "Couldn't derive example for " ++ name) $
                            deriveDSL $ fromJust $ srcExample src
        writeGenerated file $
            [""
            ,"import Data.Derive.DSL.DSL"
            ,"import Data.Derive.Internal.Derivation"
            ,""
            ,"make" ++ name ++ " :: Derivation"
            ] ++ (if srcCustom src then
                ["make" ++ name ++ " = derivationCustomDSL " ++ show name ++ " custom $"]
            else
                ["make" ++ name ++ " = derivationDSL " ++ show name ++ " dsl" ++ name
                ,""
                ,"dsl" ++ name ++ " ="
            ]) ++
            map (replicate 4 ' ' ++) (wrap 66 $ show dsl)


        let inst = dynamicDSL dsl
            instFile = takeDirectory file </> "Instance" </> name <.> "hs"
        b <- doesFileExist instFile
        if not (srcCustom src) && isJust inst then do
            writeGenerated instFile $
                ["{-# LANGUAGE FlexibleInstances, UndecidableInstances, ScopedTypeVariables #-}"] ++
                ["","module Data.Derive.Instance." ++ name ++ " where",""] ++
                (map prettyPrint $ srcImportStd src) ++
                ["import Data.Derive.Internal.Instance",""] ++
                (map prettyPrint $ fromJust inst) ++ [""]
         else when b $
            error $ "Previously generated dynamic instance can not be regenerated, " ++ name

    let imp = listToMaybe $ srcImport src
    return $ concat $
        ["<li>"
        ,"<b><a href='" ++ instUrl name imp ++ "'>" ++ name ++ "</a></b>"] ++
        [" - from the library <a href='" ++ pkgUrl pkg ++ "'>" ++ pkg ++ "</a>" | Just imp <- [imp], let pkg = fromMaybe "base" $ importPkg imp] ++
        ["</li>"]

pkgUrl x = "http://hackage.haskell.org/package/" ++ x

instUrl name Nothing = "http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-" ++ name ++ ".html"
instUrl name (Just x) = "http://hackage.haskell.org/packages/archive/" ++ pkgName ++ "/" ++ pkgVersion ++ "/doc/html/" ++ modu ++ ".html#t%3A" ++ nam
    where
        (a,b) = break (== '-') $ fromMaybe "base" $ importPkg x
        pkgName = a
        pkgVersion = if null b then "latest" else tail b
        modu = reps '.' '-' $ prettyPrint $ importModule x
        nam = case importSpecs x of Just (False,IAbs y:_) -> prettyPrint y ; _ -> name


wrap :: Int -> String -> [String]
wrap n = f . lexemes
    where
        f [] = []
        f (x:xs) = [reverse $ dropWhile isSpace $ reverse $ concat $ x:a] ++ f (dropWhile (all isSpace) b)
            where (a,b) = thisLine (n - length x) xs

        thisLine i [] = ([], [])
        thisLine i (x:xs) | j > i = ([], x:xs)
                          | otherwise = (x:a, b)
            where j = length x
                  (a,b) = thisLine (i - j) xs


lexemes :: String -> [String]
lexemes [] = []
lexemes x = a : lexemes b
    where (a,b) = lexeme x 


lexeme :: String -> (String, String)
lexeme xs@(x:_) | isAlpha x = span isAlpha xs
lexeme ('\"':xs) = let (a,b) = f xs in ('\"':a,b)
    where f ('\\':x:xs) = let (a,b) = f xs in ('\\':x:a,b)
          f ('\"':xs) = ("\"",xs)
          f (x:xs) = let (a,b) = f xs in (x:a,b)
          f [] = ([],[])
lexeme (x:xs) = ([x], xs)