module Main where
import qualified CreateBinding
import qualified Type
import Parser.Signature (Identifier(Identifier))
import CreateBinding
(formatForeignCall, formatCArrayWrapper, parseHeader,
foreignFromParameters, arrayTypeFromBool)
import qualified Text.ParserCombinators.Parsec as Parsec
import qualified Text.ParserCombinators.Parsec.Error as ParsecError
import qualified Options.Applicative as OP
import qualified System.IO as IO
import qualified System.Path.PartClass as PathClass
import qualified System.Path.IO as PathIO
import qualified System.Path as Path
import System.Path.Directory (createDirectoryIfMissing)
import System.Path (takeFileName, (</>))
import Text.Printf (printf)
import qualified Data.Csv as Csv
import qualified Data.HashMap.Lazy as HashMap
import qualified Data.Map as Map
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.ByteString.Char8 as B
import qualified Data.Vector as Vector
import qualified Data.Foldable as Fold
import qualified Data.List.HT as ListHT
import qualified Data.List as List
import Data.Traversable (for, sequenceA, traverse)
import Data.Foldable (forM_)
import Data.Vector (Vector)
import Data.ByteString (ByteString)
import Data.Map (Map)
import Data.Csv ((.:))
import Data.Tuple.HT (mapSnd, fst3, snd3, thd3)
import Data.Maybe (isNothing)
import Data.Char (toUpper)
import Data.Monoid ((<>))
import qualified Control.Monad.Exception.Synchronous as ME
import qualified Control.Monad.Trans.Writer as MW
import qualified Control.Applicative.HT as App
import qualified Control.Functor.HT as Func
import Control.Monad (when, join)
import Control.Applicative (liftA2, (<$>), (<*>))
class Type.Unification f => Generalize f where
formatGenericSig :: f Type.Poly -> String
instance Generalize Type.Foreign where
formatGenericSig = Type.formatForeign
instance Generalize Type.Wrapper where
formatGenericSig wrapper@(Type.Wrapper inputs _returnType _outputs) =
concatMap
(\(typ,dims,dir) ->
printf "%s -> " (Type.formatArray (arrayTypeFromBool dir) typ dims))
inputs ++
"IO " ++ CreateBinding.formatOutputTuple wrapper
prepareClassCall ::
(Generalize f) =>
(String, f Type.Poly) -> (String, String, String, Char -> String)
prepareClassCall (name, func) =
let typeName = map toUpper name
sig = formatGenericSig func
newtypeDef =
printf "newtype %s a = %s {get%s :: %s}" typeName typeName typeName sig
in (typeName, sig, newtypeDef,
\abbr -> printf "(%s %c.%s)" typeName abbr name)
formatClassCall ::
(Generalize f) => Char -> Char -> (String, f Type.Poly) -> String
formatClassCall singleAbbr doubleAbbr func@(name, _) =
let (typeName, sig, newtypeDef, typeBranch) = prepareClassCall func
in unlines $
"" :
"" :
newtypeDef :
"" :
printf "%s :: Class.Real a => %s" name sig :
printf "%s = get%s $ Class.switchReal %s %s"
name typeName (typeBranch singleAbbr) (typeBranch doubleAbbr) :
[]
formatClassCallRC :: (Generalize f) => (String, f Type.Poly) -> String
formatClassCallRC func@(name, _) =
let (typeName, sig, newtypeDef, typeBranch) = prepareClassCall func
in unlines $
"" :
"" :
newtypeDef :
"" :
printf "%s :: Class.Floating a => %s" name sig :
printf "%s = get%s $ Class.switchFloating %s %s %s %s" name typeName
(typeBranch 'S') (typeBranch 'D') (typeBranch 'C') (typeBranch 'Z') :
[]
insertExportList :: [String] -> String -> String
insertExportList exports modul =
(\(prefix,suffixes) ->
map fst prefix ++
case suffixes of
[] -> []
(_,suffix):_ ->
"(\n" ++ unlines (map (printf " %s,") exports) ++
" ) " ++ suffix) $
break (List.isPrefixOf "where" . snd) $
zip modul (ListHT.tails modul)
writeHeader ::
(PathClass.AbsRel ar) =>
Path.Dir ar -> B.ByteString -> Maybe [String] -> IO (Path.File ar)
writeHeader dstDir modul mexports = do
let makePath =
either (ioError . userError) (return . (dstDir </>)) . Path.parse
tmplFile <- makePath $ B.unpack modul ++ "_tmpl.hs"
dstFile <- makePath $ B.unpack modul ++ ".hs"
tmpl <- PathIO.readFile tmplFile
PathIO.writeFile dstFile $
"-- Do not edit! Automatically generated by create-lapack-ffi.\n" ++
maybe tmpl (flip insertExportList tmpl) mexports
return dstFile
indent :: String -> String
indent = unlines . map (" " ++) . lines
formatFileError :: (PathClass.AbsRel ar) => Path.File ar -> String -> String
formatFileError path msg =
printf "\n%s:1:1:\n%s" (Path.toString path) (indent msg)
formatParseError :: Parsec.ParseError -> String
formatParseError err =
let source = Parsec.errorPos err
in printf "\n%s:%d:%d:\n%s"
(Parsec.sourceName source)
(Parsec.sourceLine source)
(Parsec.sourceColumn source)
(indent $ dropWhile ('\n'==) $
ParsecError.showErrorMessages
"or" "unknown parse error" "expecting" "unexpected" "end of input"
(ParsecError.errorMessages err))
printError :: String -> IO ()
printError = IO.hPutStr IO.stderr
printFileError :: (PathClass.AbsRel ar) => Path.File ar -> String -> IO ()
printFileError path msg = printError $ formatFileError path msg
nameColumn, miscColumn, floatColumn, doubleColumn,
complexFloatColumn, complexDoubleColumn,
realColumn, complexColumn, genericColumn :: ByteString
nameColumn = B.pack "Name"
miscColumn = B.pack "Misc"
floatColumn = B.pack "Float"
doubleColumn = B.pack "Double"
complexFloatColumn = B.pack "ComplexFloat"
complexDoubleColumn = B.pack "ComplexDouble"
realColumn = B.pack "Real"
complexColumn = B.pack "Complex"
genericColumn = B.pack "Generic"
data FunctionSet = FunctionSet String (Map ByteString Path.RelFile)
newtype RelFile = RelFile {getRelFile :: Maybe Path.RelFile}
instance Csv.FromField RelFile where
parseField str =
fmap RelFile $
if B.null str
then return Nothing
else either fail (return . Just) . Path.parse . B.unpack $ str
instance Csv.FromNamedRecord FunctionSet where
parseNamedRecord m = do
name <- m .: nameColumn
when (null name) $ fail "empty name"
set <- Csv.parseNamedRecord $ HashMap.delete nameColumn m
return $ FunctionSet name $ Map.mapMaybe getRelFile set
type URL = String
processFunction ::
(PathClass.AbsRel ar) =>
(Path.File ar, Path.File ar) ->
URL -> String -> Path.File ar ->
IO (Maybe (Type.Foreign Type.Mono, Type.Wrapper Type.Mono))
processFunction (ffiFile, carrayFile) url haskellName srcPath = do
content <- PathIO.readFile srcPath
let msignature = do
sig <-
fmap MW.runWriter $
ME.mapException formatParseError $ ME.fromEither $
Parsec.parse parseHeader (Path.toString srcPath) content
when
(elem (thd3 $ fst sig)
[Just Type.ComplexSingle, Just Type.ComplexDouble]) $
ME.throw $
formatFileError srcPath "complex function result not supported"
return sig
case msignature of
ME.Exception msg -> printError msg >> return Nothing
ME.Success ((Identifier name, params, returnType), msgs) -> do
mapM_ (printFileError srcPath) msgs
let haddock =
if null url
then "\n"
else
printf "\n-- | <%s>\n"
(printf url (Path.toString $ takeFileName srcPath)
:: String)
let foreignSig = foreignFromParameters params returnType
carrayWrapper <- do
let (mono,poly) =
formatCArrayWrapper (haskellName, params, returnType)
PathIO.appendFile carrayFile $ haddock ++ mono
return poly
PathIO.appendFile ffiFile $
haddock ++ formatForeignCall ((haskellName, name), foreignSig)
return $ Just (foreignSig, carrayWrapper)
unifyFunctions ::
(Type.Unification f, PathClass.AbsRel ar) =>
String ->
Map ByteString (Path.File ar, f Type.Mono) ->
IO (Maybe (f Type.Poly), Maybe (f Type.Poly), Maybe (f Type.Poly))
unifyFunctions msg monoSigs = do
let unify uni (xPath,xSig) (yPath,ySig) = do
let m = Type.unifySignature uni xSig ySig
when (isNothing m) $ do
printFileError xPath ""
printFileError yPath msg
return m
real <-
fmap join $ sequenceA $
liftA2
(unify Type.unifyPrecision)
(Map.lookup floatColumn monoSigs)
(Map.lookup doubleColumn monoSigs)
complex <-
fmap join $ sequenceA $
liftA2
(unify Type.unifyPrecision)
(Map.lookup complexFloatColumn monoSigs)
(Map.lookup complexDoubleColumn monoSigs)
let generic =
join $ liftA2 (Type.unifySignature Type.unifyRealComplex) real complex
return (real, complex, generic)
writePolymorphic ::
(PathClass.AbsRel ar) =>
Path.Dir ar ->
ByteString ->
Vector (String, sig) ->
((String, sig) -> String) ->
IO ()
writePolymorphic dir name polySigs format = do
file <- writeHeader dir name (Just $ Fold.toList $ fmap fst polySigs)
forM_ (Fold.toList polySigs) $ PathIO.appendFile file . format
writeUnified ::
(PathClass.AbsRel ar, Generalize f) =>
Path.Dir ar ->
Vector
(String,
(Maybe (f Type.Poly), Maybe (f Type.Poly), Maybe (f Type.Poly))) ->
IO ()
writeUnified dstDir unifiedSigs = do
writePolymorphic dstDir realColumn
(Vector.mapMaybe (Func.mapSnd fst3) unifiedSigs)
(formatClassCall 'S' 'D')
writePolymorphic dstDir complexColumn
(Vector.mapMaybe (Func.mapSnd snd3) unifiedSigs)
(formatClassCall 'C' 'Z')
writePolymorphic dstDir genericColumn
(Vector.mapMaybe (Func.mapSnd thd3) unifiedSigs)
formatClassCallRC
pathArgument ::
(PathClass.FileDir fd) =>
OP.Mod OP.ArgumentFields (Path.AbsRel fd) -> OP.Parser (Path.AbsRel fd)
pathArgument = OP.argument (OP.eitherReader Path.parse)
optParser ::
OP.Parser
(URL, (Path.AbsRelFile, Path.AbsRelDir, Path.AbsRelDir, Path.AbsRelDir))
optParser =
App.lift2 (,)
(OP.strOption $
OP.long "fortran-url" <>
OP.metavar "URL" <>
OP.value "" <>
OP.help "Printf template for URL of online help") $
App.lift4 (,,,)
(pathArgument $
OP.metavar "CSV" <>
OP.help "Spreadsheet containing grouped Fortran file names")
(pathArgument $
OP.metavar "SRCDIR" <>
OP.help "Input directory containing Fortran files")
(pathArgument $
OP.metavar "FFIDIR" <>
OP.help "Output directory for Haskell FFI modules")
(pathArgument $
OP.metavar "CARRAYDIR" <>
OP.help "Output directory for Haskell CArray wrapper modules")
optionInfo :: OP.Parser a -> OP.ParserInfo a
optionInfo parser =
OP.info
(OP.helper <*> parser)
(OP.fullDesc <>
OP.progDesc
"Automated generation of low-level and mid-level bindings for LAPACK")
main :: IO ()
main = do
(url, (csvFile, srcDir, ffiDir, carrayDir)) <-
OP.execParser $ optionInfo optParser
createDirectoryIfMissing True ffiDir
createDirectoryIfMissing True carrayDir
(headers, functionSets) <-
either (ioError . userError) return . Csv.decodeByName
=<< BL.readFile (Path.toString csvFile)
dstFiles <-
fmap (Map.fromList . Fold.toList) $
for (Vector.drop 1 headers) $ \columnName ->
fmap ((,) columnName) $
liftA2 (,)
(writeHeader ffiDir columnName Nothing)
(writeHeader carrayDir columnName Nothing)
sigs <-
for functionSets $ \(FunctionSet name files) ->
fmap ((,) name . Map.mapMaybe id) $
sequenceA $
flip Map.mapWithKey files $ \modul file -> do
let srcPath = srcDir </> file
fmap ((,) srcPath) <$>
processFunction (dstFiles Map.! modul) url name srcPath
let runUnification dstDir msg select =
writeUnified dstDir =<<
traverse (Func.mapSnd (unifyFunctions msg . fmap (mapSnd select))) sigs
runUnification ffiDir "Cannot generalize FFI functions." fst
runUnification carrayDir "Cannot generalize CArray functions." snd