{-# LANGUAGE RelaxedPolyRec, PatternGuards, ViewPatterns #-}

module Parse 
    ( ParseMode (..)
    , Module (..)
    , Doc (..)
    , BBlock (..)
    , Name
    , Prompt
    , mainParse
    , getCommand
    , printName
    , parseQuickCheck
    ) where

import Text.Pandoc

import AgdaHighlight

import qualified Language.Haskell.Exts.Parser as HPar
import qualified Language.Haskell.Exts.Syntax as HSyn

{- Agda support (unfinished) -}
import qualified Agda.Syntax.Parser as APar
import qualified Agda.Syntax.Concrete as ASyn

import Data.List.Split (splitOn)
import Data.List (tails, partition, groupBy)
import Data.Function (on)
import Data.Char (isAlpha, isSpace, toUpper, isUpper)
import Control.Monad (zipWithM)

--------------------------------- data structures

data ParseMode = HaskellMode | AgdaMode
                 deriving (Show, Enum, Eq)

data Module
    = HaskellModule HSyn.Module
    | AgdaModule ASyn.Module
    deriving (Show)

data Doc
    = Doc
        Meta{-title, author, date-}
        Module{-module directives, module name, imports-}
        [BBlock]
        deriving (Show)

data BBlock
    = Text Block{-pandoc block-}
    | OneLineExercise
        Prompt
        Bool{-intentional error-}
        String
    | Exercise
        [String]{-lines-}
        [String]{-visible lines-}
        [String]{-hidden lines-}
        [Name]{-defined names-}
        [String]{-test expressions-}
        deriving (Show)

type Prompt = Char  -- see the separate documentation

type Name = String

-----------------------------------

commandList, testCommandList :: String
commandList = "AaRr" ++ testCommandList
testCommandList = "EeFfH"

-----------------------------------

mainParse :: ParseMode -> FilePath -> IO Doc
mainParse mode s = do
    c <- readFile s
    case readMarkdown pState . unlines . concatMap preprocess . lines $ c of
        Pandoc meta (CodeBlock ("",["sourceCode","literate","haskell"],[]) h: blocks) -> do
            header <- parseModule mode $ h
            fmap (Doc meta header) $ collectTests mode $ map (highlight . interpreter . Text) blocks
        Pandoc meta blocks -> do
            header <- parseModule mode $ "module Unknown where"
            fmap (Doc meta header) $ collectTests mode $ map (highlight . interpreter . Text) blocks
    where
        parseModule :: ParseMode -> String -> IO Module
        parseModule AgdaMode    m = fmap AgdaModule (APar.parse APar.moduleParser m)
        parseModule HaskellMode m = case HPar.parseModuleWithMode HPar.defaultParseMode m of
            (HPar.ParseOk m) -> return $ HaskellModule m
            parseError       -> fail $ "parseHeader: " ++ show parseError
        
        preprocess (c:'>':' ':l) | c `elem` commandList
            = ["~~~~~ {." ++ [c] ++ "}", dropWhile (==' ') l, "~~~~~", ""]
        preprocess ('|':l) 
            = []
        -- drop lines ending with "--"
        preprocess l | drop ((length l) - 2) l == "--" = []
                     | otherwise = [l]
        
        pState = defaultParserState 
            { stateSmart = True
            , stateStandalone = True
            , stateLiterateHaskell = True 
            }
        
        interpreter :: BBlock -> BBlock
        interpreter (Text (CodeBlock ("",[[x]],[]) e)) | x `elem` commandList 
            = OneLineExercise (toUpper x) (isUpper x) e
        interpreter a = a
        
        highlight :: BBlock -> BBlock
        highlight (Text (CodeBlock ("",["sourceCode","literate","haskell"],[]) code)) | mode == AgdaMode
            = (Text (RawBlock "html" $ highlightAgdaAsXHtml code))
        highlight a = a

------------------------------

collectTests :: ParseMode -> [BBlock] -> IO [BBlock]
collectTests mode l = zipWithM f l $ tail $ tails l where

    f (Text (CodeBlock ("",["sourceCode","literate","haskell"],[]) h)) l = do
        let
            isExercise = True -- not $ null $ concatMap fst exps

        (visible, hidden, funnames) <- processLines mode isExercise h
        let
            exps = [snd $ getCommand e | (OneLineExercise _ _ e) <- takeWhile p l]

            p (OneLineExercise x _ e) = x `elem` testCommandList && fst (getCommand e) == ""
            p _ = False

        return $ Exercise (lines h) visible hidden funnames exps

    f x _ = return x

processLines :: ParseMode -> Bool -> String -> IO ([String], [String], [Name])
processLines AgdaMode    = processAgdaLines
processLines HaskellMode = processHaskellLines

{- Agda support (unfinished) -}
processAgdaLines :: Bool -> String -> IO ([String], [String], [Name])
processAgdaLines isExercise l_ = do
    return ([], [], [])
{-
    let
        l = parts l_

    x <- fmap (zip l) $ mapM (Agda.parse Agda.moduleParser . ("module X where\n"++) . unlines) l
    let
        names = map toName $ concatMap (getFName . snd . snd) x

--        getFName [Agda.Module _ _ [Agda.TypedBindings _ (Agda.Arg _ _ [Agda.TBind _ a _])] declarations] 
--                  = map Agda.boundName a
        getFName [Agda.Module _ _ _ [Agda.TypeSig _ n _]]
                  = [n]
        getFName _ = []

--        isVisible [Agda.Module _ _ [Agda.TypedBindings _ (Agda.Arg _ _ [Agda.TBind _ a _])] declarations] 
--                    = True
        isVisible [Agda.Module _ _ _ [Agda.TypeSig _ n _]] = True
        isVisible _ = not isExercise

        (visible, hidden) = partition (isVisible . snd . snd) x

        toName n =  Ident $ show n

    return (concatMap fst visible, concatMap fst hidden, names)
-}

processHaskellLines :: Bool -> String -> IO ([String], [String], [Name])
processHaskellLines isExercise l_ = return (concatMap fst visible, concatMap fst hidden, names)
 where
    x = zip l $ map (HPar.parseDeclWithMode HPar.defaultParseMode . unlines) l

    l = parts l_

    names = concatMap (getFName . snd) x

    getFName (HPar.ParseOk x) = case x of
        HSyn.TypeSig _ a _                       -> map printName a
        HSyn.PatBind _ (HSyn.PVar a) _ _ _       -> [printName a]
        HSyn.FunBind (HSyn.Match _ a _ _ _ _ :_) -> [printName a]
        HSyn.TypeDecl _ a _ _                    -> [printName a]
        HSyn.DataDecl _ _ _ a _ x _              -> printName a: [printName n | HSyn.QualConDecl _ _ _ y<-x, n <- getN y]
        _                                        -> []
    getFName _ = []

    getN (HSyn.ConDecl n _) = [n]
    getN (HSyn.InfixConDecl _ n _) = [n]
    getN (HSyn.RecDecl n l) = n: concatMap fst l

    isVisible (HPar.ParseOk (HSyn.TypeSig _ _ _)) = True
    isVisible (HPar.ParseOk (HSyn.InfixDecl _ _ _ _)) = True
    isVisible _ = not isExercise

    (visible, hidden) = partition (isVisible . snd) x


parts :: String -> [[String]]
parts = groupBy (const id `on` isIndented) . lines  where
    isIndented s | all isSpace s = True
    isIndented (' ':_) = True
    isIndented _ = False

------------------------------

getCommand :: String -> (String, String)
getCommand (':':'?': (dropSpace -> Just x)) 
    = ("?", x)
getCommand (':': (span isAlpha -> (c@(_:_), dropSpace -> Just x)))
    = (c, x)
getCommand s
    = ("", s)

dropSpace :: String -> Maybe String
dropSpace (' ':y) = Just $ dropWhile (==' ') y
dropSpace "" = Just ""
dropSpace _ = Nothing

parseQuickCheck :: String -> ([String], String)
parseQuickCheck s = case splitOn ";;" s of
    l -> (init l, last l)

printName :: HSyn.Name -> Name
printName (HSyn.Ident x) = x
printName (HSyn.Symbol x) = x