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 -> String -> a
nameExtractorError = handleError "NameExtractor"
neutralName :: String
neutralName = "\\"++ r 4 ++"/\\"++ r 7 ++"\n ) ( ')"++ r 6 ++"\n( / )"++ r 7 ++"\n \\(__)|"
where r n = replicate n ' '
ignore :: OriginalFunctionSignature
ignore = OriginalFunctionSignature neutralName []
warning :: String -> a -> a
warning msg retval = unsafePerformIO $ do
withColor Yellow $ putStrLn $ "Warning: " ++ msg
return retval
stripModule :: Module -> [Decl]
stripModule x = case x of
Module _ _ _ _ _ _ g -> g
stripFunBind :: Decl -> OriginalFunctionSignature
stripFunBind x = case x of
FunBind [Match _ b c _ _ _] ->
OriginalFunctionSignature (stripName b) (map stripPattern c)
FunBind l@(Match _ b _ _ _ _ : _) | length l > 1 -> warning
("Ignoring function " ++ stripName b ++
": multi-pattern function definitions are not compilable as Feldspar functions.") ignore
PatBind _ b _ _ _ -> case stripPattern b of
Just functionName -> OriginalFunctionSignature functionName []
Nothing -> nameExtractorError InternalError ("Unsupported pattern binding: " ++ show b)
TypeSig{} -> ignore
DataDecl{} -> ignore
InstDecl{} -> ignore
TypeDecl{} -> 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 -> ModuleName
stripModule2 (Module _ b _ _ _ _ _) = b
stripModuleName :: ModuleName -> String
stripModuleName (ModuleName x) = x
getModuleName :: FilePath -> String -> String
getModuleName fileName = stripModuleName . stripModule2 . fromParseResult . customizedParse fileName
usedExtensions :: [Extension]
usedExtensions = glasgowExts ++ [ExplicitForAll]
getParseOutput :: FilePath -> IO (ParseResult Module)
getParseOutput = parseFileWithMode (defaultParseMode { extensions = usedExtensions })
customizedParse :: FilePath -> FilePath -> ParseResult Module
customizedParse fileName = parseFileContentsWithMode
(defaultParseMode
{ extensions = usedExtensions
, parseFilename = fileName
})
getFullDeclarationListWithParameterList :: FilePath -> String -> [OriginalFunctionSignature]
getFullDeclarationListWithParameterList fileName fileContents =
map stripFunBind (stripModule $ fromParseResult $ customizedParse fileName fileContents )
functionNameNeeded :: String -> Bool
functionNameNeeded functionName = functionName /= neutralName
stripUnnecessary :: [String] -> [String]
stripUnnecessary = filter functionNameNeeded
printDeclarationList :: FilePath -> IO (String -> [String])
printDeclarationList fileName = do
handle <- openFile fileName ReadMode
fileContents <- hGetContents handle
return $ getDeclarationList fileContents
printDeclarationListWithParameterList :: FilePath -> IO ()
printDeclarationListWithParameterList fileName = do
handle <- openFile fileName ReadMode
fileContents <- hGetContents handle
print $ filter (functionNameNeeded . originalFunctionName) (getFullDeclarationListWithParameterList fileName fileContents)
printParameterListOfFunction :: FilePath -> String -> IO [Maybe String]
printParameterListOfFunction = getParameterList
getDeclarationList :: FilePath -> String -> [String]
getDeclarationList fileName = stripUnnecessary . map originalFunctionName . getFullDeclarationListWithParameterList fileName
getExtendedDeclarationList :: FilePath -> String -> [OriginalFunctionSignature]
getExtendedDeclarationList fileName fileContents =
filter (functionNameNeeded . originalFunctionName)
(getFullDeclarationListWithParameterList fileName fileContents)
getParameterListOld :: FilePath -> String -> String -> [Maybe String]
getParameterListOld fileName fileContents funName = originalParameterNames $ head $
filter ((==funName) . originalFunctionName)
(getExtendedDeclarationList fileName 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 fileName fileContents)