Precompiler.hs

{-
 - Copyright (c) 2009, 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 Feldspar.Compiler -- TODO remove
import System.IO

import Language.Haskell.Exts

stripModule x = case x of
        Module a b c d e f g -> g

stripResult (ParseOk a) = a
stripResult (ParseFailed srcloc message) = error message -- TODO use srcloc

stripFunBind :: Decl -> Name
stripFunBind x = case x of
        FunBind a -> stripMatch $ head a
        PatBind a b c d e -> stripPat b
        TypeSig a b c -> Ident "DUMMY" --head b -- we don't need the type signature (yet)

stripPat (PVar x) = x

stripMatch (Match a b c d e f) = b

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 . stripResult . customizedParse

usedExtensions = glasgowExts ++ [ExplicitForall]

getParseOutput fileName = parseFileWithMode (defaultParseMode { extensions = usedExtensions }) fileName

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

getFullDeclarationList fileContents =
    map (stripName . stripFunBind) (stripModule $ stripResult $ customizedParse fileContents )

functionNameNeeded :: String -> Bool
functionNameNeeded functionName = (functionName /="DUMMY") && (functionName /="main")

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

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

getDeclarationList :: String -> [String] -- filecontents -> Stringlist
getDeclarationList = stripUnnecessary . getFullDeclarationList