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
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)
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 []
Nothing -> nameExtractorError InternalError ("Unsupported pattern binding: " ++ show b)
TypeSig a b c -> ignore
DataDecl a b c d e f g -> ignore
InstDecl a b c d e -> ignore
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
getModuleName = stripModuleName . stripModule2 . fromParseResult . customizedParse
usedExtensions = glasgowExts ++ [ExplicitForall]
getParseOutput fileName = parseFileWithMode (defaultParseMode { extensions = usedExtensions }) fileName
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
getDeclarationList :: String -> [String]
getDeclarationList = stripUnnecessary . (map originalFunctionName) . getFullDeclarationListWithParameterList
getExtendedDeclarationList :: String -> [OriginalFunctionSignature]
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)