module Feldspar.NameExtractor where

import System.IO
import System.IO.Unsafe
import Language.Haskell.Exts
import Feldspar.Compiler.Error
import Feldspar.Compiler.Backend.C.Library

data OriginalFunctionSignature = OriginalFunctionSignature {
    originalFunctionName   :: String,
    originalParameterNames :: [Maybe String]
} deriving (Show, Eq)

nameExtractorError errorClass msg = handleError "NameExtractor" errorClass msg 

neutralName = "\\"++(r 4)++"/\\"++(r 7)++"\n )  ( ')"++(r 6)++"\n(  /  )"++(r 7)++"\n \\(__)|"
    where r n = replicate n ' '

ignore = OriginalFunctionSignature neutralName []

warning msg retval = unsafePerformIO $ do
    withColor Yellow $ putStrLn $ "Warning: " ++ msg
    return retval

-- Module SrcLoc ModuleName [OptionPragma] (Maybe WarningText) (Maybe [ExportSpec]) [ImportDecl] [Decl]
stripModule x = case x of
        Module a b c d e f g -> g

stripFunBind :: Decl -> OriginalFunctionSignature
stripFunBind x = case x of
        FunBind [Match a b c d e f] ->
            OriginalFunctionSignature (stripName b) (map stripPattern c) -- going for name and parameter list
            -- "Match SrcLoc Name [Pat] (Maybe Type) Rhs Binds"
        FunBind l@((Match a b c d e f):rest) | length l > 1 -> warning
            ("Ignoring function " ++ (stripName b) ++
            ": multi-pattern function definitions are not compilable as Feldspar functions.") ignore
        PatBind a b c d e -> case stripPattern b of
            Just functionName -> OriginalFunctionSignature functionName [] -- parameterless declarations (?)
            Nothing           -> nameExtractorError InternalError ("Unsupported pattern binding: " ++ show b)
        TypeSig a b c -> ignore --head b -- we don't need the type signature (yet)
        DataDecl a b c d e f g -> ignore
        InstDecl a b c d e -> ignore
        -- TypeDecl  SrcLoc Name [TyVarBind] Type
        TypeDecl a b c d -> ignore
        unknown -> nameExtractorError InternalError ("Unexpected language element [SFB/1]: " ++ show unknown
                                                ++ "\nPlease file a feature request with an example attached.")

stripPattern :: Pat -> Maybe String
stripPattern (PVar x)         = Just $ stripName x
stripPattern PWildCard        = Nothing
stripPattern (PAsPat x _)     = Just $ stripName x
stripPattern (PParen pattern) = stripPattern pattern
stripPattern _                = Nothing

stripName :: Name -> String
stripName (Ident a) = a
stripName (Symbol a) = a

stripModule2 (Module a b c d e f g) = b

stripModuleName (ModuleName x) = x

getModuleName :: String -> String -- filecontents -> modulename
getModuleName = stripModuleName . stripModule2 . fromParseResult . customizedParse

usedExtensions = glasgowExts ++ [ExplicitForall]

-- Ultimate debug function
getParseOutput fileName = parseFileWithMode (defaultParseMode { extensions = usedExtensions }) fileName

-- or: parseFileContentsWithMode
customizedParse = parseModuleWithMode (defaultParseMode { extensions = usedExtensions })

getFullDeclarationListWithParameterList :: String -> [OriginalFunctionSignature]
getFullDeclarationListWithParameterList fileContents =
    map stripFunBind (stripModule $ fromParseResult $ customizedParse fileContents )

functionNameNeeded :: String -> Bool
functionNameNeeded functionName = (functionName /= neutralName)

stripUnnecessary :: [String] -> [String]
stripUnnecessary = filter functionNameNeeded

printDeclarationList fileName = do
    handle <- openFile fileName ReadMode
    fileContents <- hGetContents handle
    return $ getDeclarationList fileContents

printDeclarationListWithParameterList fileName = do
    handle <- openFile fileName ReadMode
    fileContents <- hGetContents handle
    putStrLn $ show $ filter (functionNameNeeded . originalFunctionName) (getFullDeclarationListWithParameterList fileContents)

printParameterListOfFunction :: FilePath -> String -> IO [Maybe String]
printParameterListOfFunction fileName functionName = getParameterList fileName functionName

-- The interface
getDeclarationList :: String -> [String] -- filecontents -> Stringlist
getDeclarationList = stripUnnecessary . (map originalFunctionName) . getFullDeclarationListWithParameterList

getExtendedDeclarationList :: String -> [OriginalFunctionSignature] -- filecontents -> ExtDeclList
getExtendedDeclarationList fileContents = filter (functionNameNeeded . originalFunctionName)
                                                 (getFullDeclarationListWithParameterList fileContents)

getParameterListOld :: String -> String -> [Maybe String]
getParameterListOld fileContents funName = originalParameterNames $ head $
    filter ((==funName) . originalFunctionName) (getExtendedDeclarationList fileContents)

getParameterList :: FilePath -> String -> IO [Maybe String]
getParameterList fileName funName = do
    handle <- openFile fileName ReadMode
    fileContents <- hGetContents handle
    return $ originalParameterNames $ head $
        filter ((==funName) . originalFunctionName) (getExtendedDeclarationList fileContents)