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<>#&@{}-$;>"
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)
PatBind a b c d e -> case stripPattern b of
Just functionName -> OriginalFeldsparFunctionSignature functionName []
Nothing -> precompilerError InternalError ("Unsupported pattern binding: " ++ show b)
TypeSig a b c -> OriginalFeldsparFunctionSignature neutralName []
DataDecl a b c d e f g -> OriginalFeldsparFunctionSignature neutralName []
InstDecl a b c d e -> OriginalFeldsparFunctionSignature neutralName []
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
getModuleName = stripModuleName . stripModule2 . fromParseResult . customizedParse
usedExtensions = glasgowExts ++ [ExplicitForall]
getParseOutput fileName = parseFileWithMode (defaultParseMode { extensions = usedExtensions }) fileName
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
getDeclarationList :: String -> [String]
getDeclarationList = stripUnnecessary . (map originalFeldsparFunctionName) . getFullDeclarationListWithParameterList
getExtendedDeclarationList :: String -> [OriginalFeldsparFunctionSignature]
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)