Precompiler.hs

--
-- Copyright (c) 2009-2010, ERICSSON AB All rights reserved.
-- 
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
-- 
--     * Redistributions of source code must retain the above copyright notice,
--       this list of conditions and the following disclaimer.
--     * Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in the
--       documentation and/or other materials provided with the distribution.
--     * Neither the name of the ERICSSON AB nor the names of its contributors
--       may be used to endorse or promote products derived from this software
--       without specific prior written permission.
-- 
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS
-- BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,
-- OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
-- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF
-- THE POSSIBILITY OF SUCH DAMAGE.
--

module Feldspar.Compiler.Precompiler.Precompiler where

import System.IO
import System.IO.Unsafe
import Language.Haskell.Exts
import Feldspar.Compiler.Error

data OriginalFeldsparFunctionSignature = OriginalFeldsparFunctionSignature {
    originalFeldsparFunctionName   :: String,
    originalFeldsparParameterNames :: [Maybe String]
} deriving (Eq)

instance Show OriginalFeldsparFunctionSignature where
    show (OriginalFeldsparFunctionSignature fn pl) = "function name: " ++ show fn ++ ", parameter list: " ++ show pl

precompilerError errorClass msg = handleError "Precompiler" errorClass msg 
    
neutralName = "kiscica<>#&@{}-$;>"

-- 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 -> OriginalFeldsparFunctionSignature
stripFunBind x = case x of
        FunBind ((Match a b c d e f):rest) -> OriginalFeldsparFunctionSignature (stripName b) (map stripPattern c) -- going for name and parameter list
            -- "Match SrcLoc Name [Pat] (Maybe Type) Rhs Binds"
            -- TODO handle other patterns, not only the first one (head)?
        PatBind a b c d e -> case stripPattern b of
            Just functionName -> OriginalFeldsparFunctionSignature functionName [] -- parameterless declarations (?)
            Nothing           -> precompilerError InternalError ("Unsupported pattern binding: " ++ show b)
        TypeSig a b c -> OriginalFeldsparFunctionSignature neutralName [] --head b -- we don't need the type signature (yet)
        DataDecl a b c d e f g -> OriginalFeldsparFunctionSignature neutralName []
        InstDecl a b c d e -> OriginalFeldsparFunctionSignature neutralName []
        -- TypeDecl  SrcLoc Name [TyVarBind] Type
        TypeDecl a b c d -> OriginalFeldsparFunctionSignature neutralName []
        unknown -> precompilerError InternalError ("Unsupported language element [SFB/1]: " ++ show unknown)

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 -> [OriginalFeldsparFunctionSignature]
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 . originalFeldsparFunctionName) (getFullDeclarationListWithParameterList fileContents)

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

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

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

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

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