lapack-ffi-tools 0.1.1 → 0.1.2
raw patch · 6 files changed
+113/−51 lines, 6 files
Files
- data/blas.csv +0/−1
- lapack-ffi-tools.cabal +4/−3
- src/CreateBinding.hs +32/−20
- src/MainAll.hs +40/−18
- src/Parser/Signature.hs +3/−1
- src/Type.hs +34/−8
data/blas.csv view
@@ -1,7 +1,6 @@ Generic,Real,Float,Double,Complex,ComplexFloat,ComplexDouble,Miscellaneous asum,asum,sasum.f,dasum.f,,,, axpy,axpy,saxpy.f,daxpy.f,axpy,caxpy.f,zaxpy.f,-cabs1,,,,cabs1,scabs1.f,dcabs1.f, casum,,,,casum,scasum.f,dzasum.f, cnrm2,,,,cnrm2,scnrm2.f,dznrm2.f, copy,copy,scopy.f,dcopy.f,copy,ccopy.f,zcopy.f,
lapack-ffi-tools.cabal view
@@ -1,5 +1,5 @@ Name: lapack-ffi-tools-Version: 0.1.1+Version: 0.1.2 License: BSD3 License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -12,7 +12,8 @@ The original implementation is written in FORTRAN. . The program in this package generates the modules- for the packages @blas-ffi@, @blas-carray@, @lapack-ffi@, @lapack-carray@+ for the packages @blas-ffi@, @blas-comfort-array@, @blas-carray@,+ @lapack-ffi@, @lapack-comfort-array@, @lapack-carray@ from the FORTRAN source files. Tested-With: GHC==7.4.2, GHC==7.8.4 Cabal-Version: 1.14@@ -22,7 +23,7 @@ data/lapack.csv Source-Repository this- Tag: 0.1.1+ Tag: 0.1.2 Type: darcs Location: http://hub.darcs.net/thielema/lapack-ffi-tools/
src/CreateBinding.hs view
@@ -168,6 +168,12 @@ Parser.InputWorkspace -> True _ -> False +isTmpIOArray :: Parser.Direction -> Bool+isTmpIOArray dir =+ case dir of+ Parser.Input -> False+ _ -> True+ contFromArrayType :: Parameter -> String contFromArrayType (name, (typ, dims, dir)) = case dims of@@ -176,7 +182,7 @@ then contFromType typ ++ " " ++ name else "Call.alloca" Type.Array _ ->- (if isIOArray dir then "Call.ioarray " else "Call.array ") ++ name+ (if isTmpIOArray dir then "Call.ioarray " else "Call.array ") ++ name Type.Function _ _ -> "pure " ++ name parens :: String -> String@@ -185,12 +191,6 @@ parensIfNeeded :: String -> String parensIfNeeded expr = if all isAlphaNum expr then expr else parens expr -arrayTypeFromBool :: Bool -> String-arrayTypeFromBool mutable = if mutable then "IOCArray" else "CArray"--arrayTypeFromDir :: Parser.Direction -> String-arrayTypeFromDir = arrayTypeFromBool . isIOArray- isInputDir :: Parser.Direction -> Bool isInputDir dir = case dir of@@ -274,22 +274,27 @@ peekOut :: Parameter -> String-peekOut (name, (typ, dims, _dir)) =+peekOut (name, (typ, dims, dir)) = case dims of Type.Scalar -> case typ of Type.Character -> printf "fmap castCCharToChar (peek %sPtr)" name Type.Integer -> printf "fmap fromIntegral (peek %sPtr)" name _ -> printf "peek %sPtr" name- Type.Array _ -> "pure " ++ name+ Type.Array _ ->+ if isIOArray dir+ then "pure " ++ name+ else "Call.freezeArray " ++ name Type.Function _ _ -> printf "error \"function %s cannot be an output\"" name -formatOutputTuple :: Type.Format typ => Type.Wrapper typ -> String-formatOutputTuple (Type.Wrapper _inputs returnType outputs) =+formatOutputTuple ::+ (Type.Array array, Type.Format typ) =>+ array -> Type.Wrapper array typ -> String+formatOutputTuple array (Type.Wrapper _inputs returnType outputs) = let outputTuple = CreateBinding.parens $ List.intercalate ", " $- map (uncurry $ Type.formatArray "CArray") outputs+ map (uncurry $ Type.formatArray array False) outputs in case (returnType, outputs) of (Nothing, _) -> outputTuple (Just t, []) -> Type.format t@@ -297,9 +302,12 @@ (Just t, _) -> printf "(%s, %s)" (Type.format t) outputTuple -formatCArrayWrapper ::- (String, [Parameter], Maybe Type.Mono) -> (String, Type.Wrapper Type.Mono)-formatCArrayWrapper (name, params0, returnType) =+formatWrapper ::+ (Type.Array array) =>+ array ->+ (String, [Parameter], Maybe Type.Mono) ->+ (String, Type.Wrapper array Type.Mono)+formatWrapper array (name, params0, returnType) = let prepare (param,info) = (param, mapSnd3@@ -372,16 +380,20 @@ map (\(param,(typ,dims,dir)) -> printf " %s {- ^ %s -} ->"- (Type.formatArray (arrayTypeFromDir dir) typ dims) param)+ (Type.formatArray array (isIOArray dir) typ dims) param) inputs ++- (" IO " ++ formatOutputTuple wrapper) :+ (" IO " ++ formatOutputTuple array wrapper) : (name ++ concatMap ((' ':) . fst) inputs ++ " = do") : map (\(param,(dimVars,dir)) -> let format =- if isIOArray dir- then " %s <- Call.sizes%d <$> getBounds %s"- else " let %s = Call.sizes%d $ bounds %s"+ Type.caseComfortCArray array+ (if isIOArray dir+ then " let %s = Call.sizes%d $ MutArray.shape %s"+ else " let %s = Call.sizes%d $ Array.shape %s")+ (if isIOArray dir+ then " %s <- Call.sizes%d <$> getBounds %s"+ else " let %s = Call.sizes%d $ bounds %s") dimIdents = Match.take dimVars $ dimNames param in printf format (Type.formatTuple dimIdents) (length dimIdents) param)
src/MainAll.hs view
@@ -4,8 +4,8 @@ import qualified Type import Parser.Signature (Identifier(Identifier)) import CreateBinding- (formatForeignCall, formatCArrayWrapper, parseHeader,- foreignFromParameters, arrayTypeFromBool)+ (formatForeignCall, formatWrapper, parseHeader,+ foreignFromParameters) import qualified Text.ParserCombinators.Parsec as Parsec import qualified Text.ParserCombinators.Parsec.Error as ParsecError@@ -36,7 +36,7 @@ import Data.HashMap.Lazy (HashMap) import Data.Map (Map) import Data.Csv ((.:))-import Data.Tuple.HT (mapSnd, thd3)+import Data.Tuple.HT (mapSnd, fst3, snd3, thd3) import Data.Maybe (isNothing, mapMaybe) import Data.Bool.HT (if') import Data.Char (toUpper)@@ -57,13 +57,15 @@ instance Generalize Type.Foreign where formatGenericSig = Type.formatForeign -instance Generalize Type.Wrapper where+instance (Type.Array array) => Generalize (Type.Wrapper array) where formatGenericSig wrapper@(Type.Wrapper inputs _returnType _outputs) =+ let array = Type.arrayFromWrapper wrapper+ in concatMap- (\(typ,dims,dir) ->- printf "%s -> " (Type.formatArray (arrayTypeFromBool dir) typ dims))+ (\(typ,dims,mut) ->+ printf "%s -> " (Type.formatArray array mut typ dims)) inputs ++- "IO " ++ CreateBinding.formatOutputTuple wrapper+ "IO " ++ CreateBinding.formatOutputTuple array wrapper prepareClassCall :: (Generalize f) => (String, f Type.Poly) -> (String, String, String)@@ -228,10 +230,13 @@ processFunction :: (PathClass.AbsRel ar) => Bool ->- (Path.File ar, Path.File ar) ->+ (Path.File ar, Path.File ar, Path.File ar) -> URL -> String -> Path.File ar ->- IO (Maybe (Type.Foreign Type.Mono, Type.Wrapper Type.Mono))-processFunction output (ffiFile, carrayFile) url haskellName srcPath = do+ IO (Maybe (Type.Foreign Type.Mono,+ Type.Wrapper Type.ComfortArray Type.Mono,+ Type.Wrapper Type.CArray Type.Mono))+processFunction output+ (ffiFile, comfortArrayFile, carrayFile) url haskellName srcPath = do content <- PathIO.readFile srcPath let msignature = do sig <-@@ -256,14 +261,21 @@ (printf url (Path.toString $ takeFileName srcPath) :: String) let foreignSig = foreignFromParameters params returnType+ comfortArrayWrapper <- do+ let (mono,poly) =+ formatWrapper Type.ComfortArray+ (haskellName, params, returnType)+ when output $ PathIO.appendFile comfortArrayFile $ haddock ++ mono+ return poly carrayWrapper <- do let (mono,poly) =- formatCArrayWrapper (haskellName, params, returnType)+ formatWrapper Type.CArray+ (haskellName, params, returnType) when output $ PathIO.appendFile carrayFile $ haddock ++ mono return poly when output $ PathIO.appendFile ffiFile $ haddock ++ formatForeignCall ((haskellName, name), foreignSig)- return $ Just (foreignSig, carrayWrapper)+ return $ Just (foreignSig, comfortArrayWrapper, carrayWrapper) unifyFunctions :: (Type.Unification f, PathClass.AbsRel ar) =>@@ -345,7 +357,8 @@ optParser :: OP.Parser- (URL, (Path.AbsRelFile, Path.AbsRelDir, Path.AbsRelDir, Path.AbsRelDir))+ (URL, (Path.AbsRelFile, Path.AbsRelDir,+ (Path.AbsRelDir, Path.AbsRelDir, Path.AbsRelDir))) optParser = App.lift2 (,) (OP.strOption $@@ -353,17 +366,22 @@ OP.metavar "URL" <> OP.value "" <> OP.help "Printf template for URL of online help") $- App.lift4 (,,,)+ App.lift3 (,,) (pathArgument $ OP.metavar "CSV" <> OP.help "Spreadsheet containing grouped Fortran file names") (pathArgument $ OP.metavar "SRCDIR" <> OP.help "Input directory containing Fortran files")+ $+ App.lift3 (,,) (pathArgument $ OP.metavar "FFIDIR" <> OP.help "Output directory for Haskell FFI modules") (pathArgument $+ OP.metavar "COMFORTARRAYDIR" <>+ OP.help "Output directory for Haskell comfort-array wrapper modules")+ (pathArgument $ OP.metavar "CARRAYDIR" <> OP.help "Output directory for Haskell CArray wrapper modules") @@ -378,9 +396,10 @@ main :: IO () main = do- (url, (csvFile, srcDir, ffiDir, carrayDir)) <-+ (url, (csvFile, srcDir, (ffiDir, comfortArrayDir, carrayDir))) <- OP.execParser $ optionInfo optParser createDirectoryIfMissing True ffiDir+ createDirectoryIfMissing True comfortArrayDir createDirectoryIfMissing True carrayDir (headers, functionSets) <-@@ -392,8 +411,9 @@ for (filter (not . flip HashMap.member unifiedColumnsMap) $ Fold.toList headers) $ \columnName -> fmap ((,) columnName) $- liftA2 (,)+ App.lift3 (,,) (writeHeader ffiDir columnName Nothing)+ (writeHeader comfortArrayDir columnName Nothing) (writeHeader carrayDir columnName Nothing) sigs <-@@ -417,5 +437,7 @@ 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+ runUnification ffiDir "Cannot generalize FFI functions." fst3+ runUnification comfortArrayDir+ "Cannot generalize comfort-array functions." snd3+ runUnification carrayDir "Cannot generalize CArray functions." thd3
src/Parser/Signature.hs view
@@ -60,7 +60,9 @@ (Type.ComplexDouble <$ Parsec.string "COMPLEX"))) <|> (Parsec.string "COMPLEX" >>- ((Type.ComplexDouble <$ Parsec.string "*16") <|> return Type.ComplexSingle))+ ((Type.ComplexDouble <$ Parsec.string "*16")+ <|>+ return Type.ComplexSingle)) expression :: Parser String expression =
src/Type.hs view
@@ -95,15 +95,37 @@ mfilter (Fold.any isVar) $ unify uni floatSig doubleSig -data Wrapper typ =+data ComfortArray = ComfortArray+data CArray = CArray++class Array array where+ arrayFromWrapper :: Wrapper array typ -> array+ formatArrayName :: array -> Bool -> String+ formatDimName :: array -> String+ caseComfortCArray :: array -> a -> a -> a++instance Array ComfortArray where+ arrayFromWrapper _ = ComfortArray+ formatArrayName ComfortArray mutable =+ (if mutable then "IO" else "") ++ "Array"+ formatDimName ComfortArray = "ZeroInt"+ caseComfortCArray ComfortArray x _ = x++instance Array CArray where+ arrayFromWrapper _ = CArray+ formatArrayName CArray mutable = (if mutable then "IO" else "") ++ "CArray"+ formatDimName CArray = "Int"+ caseComfortCArray CArray _ x = x++data Wrapper array typ = Wrapper [(typ, Mapping String typ, Bool)] (Maybe typ) [(typ, Mapping String typ)] -instance Foldable Wrapper where+instance Foldable (Wrapper array) where foldMap f (Wrapper inputs returnType outputs) = foldMap (f.fst3) inputs <> foldMap f returnType <> foldMap (f.fst) outputs -instance Unification Wrapper where+instance Unification (Wrapper array) where unify uni (Wrapper aInputs aReturn aOutputs) (Wrapper bInputs bReturn bOutputs) = @@ -143,8 +165,8 @@ [x] -> x _ -> "(" ++ List.intercalate "," elems ++ ")" -formatIndex :: [String] -> String-formatIndex = formatTuple . flip Match.replicate "Int"+formatShape :: (Array array) => array -> [String] -> String+formatShape array = formatTuple . flip Match.replicate (formatDimName array) formatPtr :: (Format typ) => typ -> String formatPtr typ = "Ptr " ++ format typ@@ -154,11 +176,15 @@ printf "FunPtr (%sIO %s)" (concat $ replicate n $ formatPtr param ++ " -> ") (format ret) -formatArray :: (Format typ) => String -> typ -> Mapping String typ -> String-formatArray array elm mapping =+formatArray ::+ (Array array, Format typ) =>+ array -> Bool -> typ -> Mapping String typ -> String+formatArray array mutable elm mapping = case mapping of Scalar -> formatParameter elm- Array dims -> array ++ " " ++ formatIndex dims ++ " " ++ format elm+ Array dims ->+ formatArrayName array mutable ++ " " +++ formatShape array dims ++ " " ++ format elm Function n param -> formatFunPtr n param elm instance Format Mono where