packages feed

hasktorch-codegen (empty) → 0.0.1.0

raw patch · 21 files changed

+2308/−0 lines, 21 filesdep +QuickCheckdep +basedep +containers

Dependencies added: QuickCheck, base, containers, directory, hashable, hasktorch-codegen, hspec, hspec-discover, megaparsec, optparse-applicative, pretty-show, text, unordered-containers

Files

+ exe/CLIOptions.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE ScopedTypeVariables #-}+module CLIOptions where++import Options.Applicative as OptParse+import Data.List (intercalate)+import Data.Monoid ((<>))+import Data.Proxy (Proxy(..))++import CodeGen.Types++-- ========================================================================= --++-- | CLI Options+--+-- FIXME: Allow taking @HashSet <types>@ so that we can run multiple targets at+-- the same time.+data Options = Options+  { codegenType :: CodeGenType+  , libraries   :: LibType+  , verbose     :: Bool+  }+++-- | optparse-applicative Parser to annotate and parse our CLI+cliOptions :: OptParse.Parser Options+cliOptions = Options+  <$> option auto+     ( long "type"+    <> short 't'+    <> help "which type of codegen to run"+    <> metavar (enumVar (Proxy :: Proxy CodeGenType) generatable))+  <*> option auto+     ( long "lib"+    <> short 'l'+    <> help "which library to run against"+    <> metavar (enumVar (Proxy :: Proxy LibType) supported))+  <*> switch+     ( long "verbose"+    <> short 'v'+    <> help "whether or not to print debugging informations")+ where+  enumVar+    :: forall a . (Bounded a, Enum a, Show a)+    => Proxy a -> (a -> Bool) -> String+  enumVar _ f+    = "[" ++ intercalate "|" (show <$> filter f [minBound..maxBound::a]) ++ "]"+++
+ exe/Main.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Main where++import Control.Monad (when)+import Data.List (nub)+import Text.Show.Pretty (ppShow)+import Options.Applicative (ParserInfo, execParser, info, (<**>), helper, idm)++import CodeGen.FileMappings+import CodeGen.Types+import CodeGen.Render (writeHaskellModule, parseFile)++import CLIOptions++-- ========================================================================= --++main :: IO ()+main = execParser opts >>= run+ where+  opts :: ParserInfo Options+  opts = info (cliOptions <**> helper) idm+++run :: Options -> IO ()+run os = do+  when (verbose os) $ putStrLn $ unwords+    [ "Running"+    , show gentype+    , "codegen for"+    , show lib+    , "files"+    ]+  if supported lib+  then do+    mapM_ (runPipeline os) (files lib gentype)+    when (verbose os) $ putStrLn "Done"+  else putStrLn ("Code generation not enabled for " ++ show lib)+ where+  lib :: LibType+  lib = libraries os++  gentype :: CodeGenType+  gentype = codegenType os+++runPipeline+  :: Options+  -> (String, TemplateType -> [Function] -> HModule)+  -> IO ()+runPipeline os (headerPath, makeModuleConfig) = do+  -- TODO: @nub@ is a hack until proper treatment of+  --       conditioned templates is implemented+  bindingsUniq <- nub <$> parseFile (libraries os) (codegenType os) headerPath++  when (verbose os) $ do+    putStrLn $ "First signature of " ++ show (length bindingsUniq)+    putStrLn $ ppShow (take 1 bindingsUniq)++  mapM_ (writeHaskellModule bindingsUniq makeModuleConfig) typeList++  when (verbose os) $+    putStrLn $ "Number of functions generated: "+      ++ show (length typeList * length bindingsUniq)+ where+  typeList :: [TemplateType]+  typeList = generatedTypes (libraries os) (codegenType os)+++
+ hasktorch-codegen.cabal view
@@ -0,0 +1,94 @@+cabal-version: 2.2+-- * * * * * * * * * * * * WARNING * * * * * * * * * * * *+-- This file has been AUTO-GENERATED by dhall-to-cabal.+--+-- Do not edit it by hand, because your changes will be over-written!+--+-- Instead, edit the source Dhall file, namely+-- 'ffi/codegen/hasktorch-codegen.dhall', and re-generate this file by running+-- 'dhall-to-cabal -- ffi/codegen/hasktorch-codegen.dhall > hasktorch-codegen.cabal'.+-- * * * * * * * * * * * * WARNING * * * * * * * * * * * *+name: hasktorch-codegen+version: 0.0.1.0+license: BSD-3-Clause+maintainer: Sam Stites <fnz@fgvgrf.vb>, Austin Huang <nhfgvau@nyhz.zvg.rqh> - cipher:ROT13+author: Hasktorch dev team+homepage: https://github.com/hasktorch/hasktorch#readme+bug-reports: https://github.com/hasktorch/hasktorch/issues+synopsis: Code generation tools for Hasktorch+description:+    Codegen will generate FFI code which layes the foundation for the Hasktorch library.+category: Tensors, Machine Learning, AI, FFI Tools, Code Generation+build-type: Simple++source-repository head+    type: git+    location: https://github.com/hasktorch/hasktorch++library+    exposed-modules:+        CodeGen.FileMappings+        CodeGen.Parse+        CodeGen.Parse.Cases+        CodeGen.Prelude+        CodeGen.Render+        CodeGen.Render.C+        CodeGen.Render.Function+        CodeGen.Render.Haskell+        CodeGen.Types+        CodeGen.Types.CLI+        CodeGen.Types.HsOutput+        CodeGen.Types.Parsed+    hs-source-dirs: src+    other-modules:+        Paths_hasktorch_codegen+    autogen-modules:+        Paths_hasktorch_codegen+    default-language: Haskell2010+    default-extensions: LambdaCase OverloadedStrings+    build-depends:+        base (==4.7 || >4.7) && <5,+        containers ==0.5.10 || >0.5.10,+        directory ==1.3.0 || >1.3.0,+        hashable ==1.2.7 || >1.2.7,+        megaparsec ==6.5.0 || >6.5.0,+        pretty-show ==1.7 || >1.7,+        text ==1.2.2 || >1.2.2,+        unordered-containers ==0.2.9 || >0.2.9++executable ht-codegen+    main-is: Main.hs+    hs-source-dirs: exe+    other-modules:+        CLIOptions+    default-language: Haskell2010+    default-extensions: LambdaCase OverloadedStrings+    build-depends:+        base (==4.7 || >4.7) && <5,+        hasktorch-codegen -any,+        pretty-show ==1.7 || >1.7,+        optparse-applicative ==0.14.2 || >0.14.2++test-suite spec+    type: exitcode-stdio-1.0+    main-is: Spec.hs+    hs-source-dirs: tests+    other-modules:+        CodeGen.Instances+        CodeGen.ParseSpec+        CodeGen.RenderSpec+        CodeGen.Render.CSpec+        CodeGen.Render.FunctionSpec+    default-language: Haskell2010+    default-extensions: LambdaCase OverloadedStrings+    build-depends:+        QuickCheck ==2.11 || >2.11,+        base (==4.7 || >4.7) && <5,+        containers ==0.5.10 || >0.5.10,+        hasktorch-codegen -any,+        hspec ==2.4.4 || >2.4.4,+        hspec-discover ==2.5.0 || >2.5.0,+        megaparsec ==6.5.0 || >6.5.0,+        pretty-show ==1.7 || >1.7,+        text ==1.2.2 || >1.2.2+
+ src/CodeGen/FileMappings.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE OverloadedStrings #-}+module CodeGen.FileMappings+  ( files+  , HeaderFile+  ) where++import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T++import CodeGen.Types+import CodeGen.Prelude+import CodeGen.Render (makeModule)++type HeaderFile = FilePath++($:) :: LibType -> CodeGenType -> (LibType -> CodeGenType -> x) -> x+($:) a b fn = fn a b++files :: LibType -> CodeGenType -> [(String, TemplateType -> [Function] -> HModule)]+files TH = \case+  GenericFiles -> map (($:) TH GenericFiles)+    [ mkModule' "Blas"+    , mkModule' "Lapack"+    , mkModule' "Storage"+    , mkModule  (ModuleSuffix "Storage") "StorageCopy"+    , mkModule' "Tensor"+    , mkModule  (ModuleSuffix "Tensor") "TensorConv"+    , mkModule  (ModuleSuffix "Tensor") "TensorCopy"+    , mkModule  (ModuleSuffix "Tensor") "TensorLapack"+    , mkModule  (ModuleSuffix "Tensor") "TensorMath"+    , mkModule  (ModuleSuffix "Tensor") "TensorRandom"+    , mkModule' "Vector"+    ]+  ConcreteFiles -> map (($:) TH ConcreteFiles)+    [ mkModule' "File"+    , mkModule' "DiskFile"+    , mkModule' "Atomic"+    , mkModule' "Half"+    , mkModule' "LogAdd"+    , mkModule' "Random"+    , mkModule' "Size"+    , mkModule' "Storage"+    , mkModule' "MemoryFile"+    ]++files THC = \case+  GenericFiles -> map (($:) THC GenericFiles)+    [ mkModule' "Storage"+    , mkModule  (ModuleSuffix "Storage") "StorageCopy"+    , mkModule' "Tensor"+    , mkModule  (ModuleSuffix "Tensor") "TensorCopy"+    , mkModule  (ModuleSuffix "Tensor") "TensorIndex"+    , mkModule  (ModuleSuffix "Tensor") "TensorMasked"+    , mkModule  (ModuleSuffix "Tensor") "TensorMath"+    , mkModule  (ModuleSuffix "Tensor") "TensorMathBlas"+    , mkModule  (ModuleSuffix "Tensor") "TensorMathCompare"+    , mkModule  (ModuleSuffix "Tensor") "TensorMathCompareT"+    --  NOTE: CUDA implementation of LAPACK functions+    , mkModule  (ModuleSuffix "Tensor") "TensorMathMagma"+    , mkModule  (ModuleSuffix "Tensor") "TensorMathPairwise"+    , mkModule  (ModuleSuffix "Tensor") "TensorMathPointwise"+    , mkModule  (ModuleSuffix "Tensor") "TensorMathReduce"+    , mkModule  (ModuleSuffix "Tensor") "TensorMathScan"+    , mkModule  (ModuleSuffix "Tensor") "TensorMode"+    , mkModule  (ModuleSuffix "Tensor") "TensorRandom"+    , mkModule  (ModuleSuffix "Tensor") "TensorScatterGather"+    , mkModule  (ModuleSuffix "Tensor") "TensorSort"+    , mkModule  (ModuleSuffix "Tensor") "TensorTopK"+    ]+  -- does not account for any .cuh files+  ConcreteFiles -> map (($:) THC ConcreteFiles)+    [ mkModule' "Allocator"+    , mkModule' "Blas"+    , mkModule' "CachingAllocator"+    , mkModule' "CachingHostAllocator"+    -- , mkModule' "THCDeviceTensor" -- this is a .cuh+    , mkModule' "Half"+    -- , mkModule' "THCReduce" -- this is a .cuh+    , mkModule' "Sleep"+    , mkModule' "Storage"+    , mkModule' "StorageCopy"+    , mkModule' "Stream"+    , mkModule' "Tensor"+    , mkModule' "TensorConv"+    , mkModule' "TensorCopy"+    , mkModule' "TensorMath"+    , mkModule' "TensorMath"+    , mkModule' "TensorRandom"+    , mkModule' "ThreadLocal"++    , mkGeneralFile+    ]+files THNN   = \case { GenericFiles -> map (($:) THNN   GenericFiles) [ mkModule' "" ]; ConcreteFiles -> [] }+files THCUNN = \case { GenericFiles -> map (($:) THCUNN GenericFiles) [ mkModule' "" ]; ConcreteFiles -> [] }+files _      = \case { GenericFiles -> []; ConcreteFiles -> [] }++mkGeneralFile+  :: LibType+  -> CodeGenType+  -> (FilePath, TemplateType -> [Function] -> HModule)+mkGeneralFile lt cgt+  = ( srcDir lt cgt <> show lt <> "General.h.in"+    , makeModule lt (TextPath . T.pack $ outDir lt) cgt (show lt <> "General.h") modsuff filesuff)+ where+  modsuff = "General"+  filesuff = "General"+++mkModule+  :: ModuleSuffix+  -> FileSuffix+  -> LibType+  -> CodeGenType+  -> (FilePath, TemplateType -> [Function] -> HModule)+mkModule modsuff filesuff lt cgt+  = (srcDir lt cgt <> hf, makeModule lt (TextPath . T.pack $ outDir lt) cgt hf modsuff filesuff)+ where+  hf :: FilePath+  hf = show lt <> T.unpack (textFileSuffix filesuff) <> ".h"+++mkModule'+  :: Text+  -> LibType+  -> CodeGenType+  -> (FilePath, TemplateType -> [Function] -> HModule)+mkModule' suff = mkModule (ModuleSuffix suff) (FileSuffix suff)+
+ src/CodeGen/Parse.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-}+module CodeGen.Parse where+  -- ( Parser+  -- , parser+  -- , functionConcrete+  -- , Parsable(..)+  -- , Arg(..)+  -- , Function(..)+  -- ) where++import CodeGen.Prelude+import CodeGen.Types+import Control.Arrow (second)++import qualified Data.Text as T+import qualified CodeGen.Render.C as C++-- ----------------------------------------+-- File parser for TH templated header files+-- ----------------------------------------++ptr :: Parser ()+ptr = void (space >> char '*')++ptr2 :: Parser ()+ptr2 = ptr >> ptr++{-+nntypes :: Parser Parsable+nntypes = forLibraries go+ where+  go :: LibType -> Parser Parsable+  go = genericParsers NNType . C.renderNNType+-}++tentypes :: Parser Parsable+tentypes = forLibraries go+ where+  go :: LibType -> Parser Parsable+  go lt = genericParsers allTenTypes TenType C.renderTenType+++ctypes :: Parser Parsable+ctypes = genericParsers [minBound..maxBound :: CType] CType C.renderCType+++-- | build a parser that will try to find the double-pointer- or pointer- variant first.+genericParsers+  :: forall x . [x]+  -> (x -> Parsable)+  -> (x -> Text)+  -> Parser Parsable+genericParsers xs cons render = asum $ map goAll xs+ where+  goAll :: x -> Parser Parsable+  goAll x+    -- search for any double pointer first+    =   try (Ptr . Ptr <$> (go1 x <* ptr2))++    -- then any pointer+    <|> try (Ptr       <$> (go1 x <* ptr))++    -- finally, all of our concrete types and wrap them in the Parsable format+    <|> try (go1 x)++  go1 :: x -> Parser Parsable+  go1 = fmap cons . typeParser render+++typeParser :: (x -> Text) -> x -> Parser x+typeParser render t = string (T.unpack $ render t) >> pure t+++-- | parse a library-dependent parser across all of our supported libraries+forLibraries :: (LibType -> Parser x) -> Parser x+forLibraries go = asum (map go supportedLibraries)++-------------------------------------------------------------------------------++parsabletypes :: Parser Parsable+parsabletypes+  = do+  typeModifier+  try tentypes {- <|> try nntypes -} <|> ctypes+ where+  typeModifier :: Parser ()+  typeModifier =+        void (try (string "const "))+    <|> void (try (string "unsigned "))+    <|> void (try (string "struct "))+    <|> space+++-------------------------------------------------------------------------------++-- Landmarks+api :: Parser ()+api = forLibraries go+ where+  go :: LibType -> Parser ()+  go lt = void $ try (string (show lt <> "_API"))++semicolon :: Parser ()+semicolon = void (char ';')++functionArg :: Parser Arg+functionArg = do+  space+  optional $ try (string "volatile" <|> string "const") <* space1+  argType <- parsabletypes <* space+  -- e.g. declaration sometimes has no variable name - eg Storage.h+  argName <- optional $ some (alphaNumChar <|> char '_') <* space+  endsInComma <|> endsInParen+    -- <|> lookAhead (void $ char ')')+  pure $ Arg argType (maybe "" T.pack argName)+ where++  endsInComma :: Parser ()+  endsInComma+    =   try (void (char ',' >> space >> eol))+    <|> try (void (char ',' >> space >> string "//" >> some (notChar '\n') >> eol))+    <|> void (char ',')++  endsInParen :: Parser ()+  endsInParen+    =   try (space >> string "//" >> some (notChar '\n') >> eol >> space >> lookAhead (void $ char ')'))+    <|> lookAhead (void $ char ')')++functionArgs :: Parser [Arg]+functionArgs = do+  try (char '(' >> space >> void eol) <|> void (char '(')+  args <- some functionArg+  char ')'+  pure args++genericPrefixes :: Parser (LibType, Text)+genericPrefixes = second T.pack <$> asum (foldMap go supportedLibraries)+ where+  prefix :: LibType -> String -> Parser (LibType, String)+  prefix lt x = try (((,) <$> typeParser tshow lt <*> string x) <* string "_(")++  go :: LibType -> [Parser (LibType, String)]+  go lt = map (prefix lt) ["Tensor", "Blas", "Lapack", "Storage", "Vector", ""]+++function :: Parser (Maybe Function)+function = do+  optional space -- this is for poorly formatted functions in THCUNN+  optional (api >> space)+  funReturn' <- parsabletypes <* space+  (funPrefix', funName') <- choice [ try genericName, (Nothing,) <$> concreteName ]+  funArgs' <- functionArgs <* space <* semicolon+  optional (try comment)+  pure . pure $ Function funPrefix' funName' funArgs' funReturn'+ where+  genericName :: Parser (Maybe (LibType, Text), Text)+  genericName = do+    pref <- genericPrefixes+    name <- concreteName <* string ")" <* space+    pure (Just pref, name)++  concreteName :: Parser Text+  concreteName = T.pack <$> (some (alphaNumChar <|> char '_') <|> string "") <* space++inlineComment :: Parser ()+inlineComment = do+  space+  string "//"+  some (alphaNumChar <|> char '_' <|> char ' ')+  void $ eol <|> (some (notChar '\n') >> eol)++-- | skip over a _single-line_ of block comment -- something which seems standard in the libTH.+comment :: Parser ()+comment = space >> void (string "/*" *> some (alphaNumChar <|> char '_' <|> char ' ') <* string "*/")++-- | run a parser to find all possible functions, returning one maybe type per-line.+parser :: Parser [Maybe Function]+parser = some (try constant <|> try function <|> skip)++-- | returns a Maybe Function because we actually don't care about constants when generating FFI code.+constant :: Parser (Maybe Function)+constant = do+  -- THLogAdd has constants, these are not surfaced+  string "const" >> space+  parsabletypes >> space+  some (alphaNumChar <|> char '_') >> semicolon+  pure Nothing++-- | Skip a line because we have failed to find a function+skip :: Parser (Maybe Function)+skip = do+  (not <$> atEnd) >>= guard+  void $ many (notChar '\n') <* (void eol <|> eof)+  pure Nothing++
+ src/CodeGen/Parse/Cases.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE OverloadedLists #-}+module CodeGen.Parse.Cases+  ( type2real+  , type2hsreal+  , type2accreal+  , checkFunction+  ) where++import CodeGen.Prelude hiding (char)+import qualified Data.HashMap.Strict as M+import qualified Data.HashSet as S++import CodeGen.Types hiding (prefix)++uchar, long, char :: (HsRep -> CRep -> x) -> x+uchar  cons = cons "Foreign.C.Types.CUChar"  "unsigned char"+long   cons = cons "Foreign.C.Types.CLong"   "long"+char   cons = cons "Foreign.C.Types.CChar"   "char"+double cons = cons "Foreign.C.Types.CDouble" "double"+float  cons = cons "Foreign.C.Types.CFloat"  "float"+int    cons = cons "Foreign.C.Types.CInt"    "int"+short  cons = cons "Foreign.C.Types.CShort"  "short"+half   cons = cons (HsRep $ prefix TH "Half") "THHalf"++prefix :: LibType -> Text -> Text+prefix lt t = "Torch.Types." <> tshow lt <> ".C"<> tshow lt <> t++signatureAliases :: LibType -> TemplateType -> Maybe (CTensor, CReal, CAccReal, CStorage)+signatureAliases lt = \case+  GenByte   -> Just (mkTuple "Byte"   uchar  long)+  GenChar   -> Just (mkTuple "Char"   char   long)+  GenDouble -> Just (mkTuple "Double" double double)+  GenFloat  -> Just (mkTuple "Float"  float  double)+  GenHalf   -> Just (mkTuple "Half"   half   float)+  GenInt    -> Just (mkTuple "Int"    int    long)+  GenLong   -> Just (mkTuple "Long"   long   long)+  GenShort  -> Just (mkTuple "Short"  short  long)+  GenNothing -> Nothing+ where+  mkRep :: (HsRep -> CRep -> x) -> Text -> Text -> x+  mkRep cons suffix t = cons (HsRep . prefix lt $ t <> suffix) (CRep $ t <> suffix)++  mkCTensor :: Text -> CTensor+  mkCTensor = mkRep CTensor "Tensor"++  mkCStorage :: Text -> CStorage+  mkCStorage = mkRep CStorage "Storage"++  mkTuple :: Text -> ((HsRep -> CRep -> CReal) -> CReal) -> ((HsRep -> CRep -> CAccReal) -> CAccReal) -> (CTensor, CReal, CAccReal, CStorage)+  mkTuple t r ac = (mkCTensor t, r CReal, ac CAccReal, mkCStorage t)+++type2real :: LibType -> TemplateType -> Text+type2real lt t = case signatureAliases lt t of+  Just (_, CReal hs _, _, _) -> stripModule hs+  Nothing -> "" -- impossible "TemplateType is concrete and should not have been called"++-- | spliced text to use for function names+type2hsreal :: TemplateType -> Text+type2hsreal = \case+  GenByte    -> "Byte"+  GenChar    -> "Char"+  GenDouble  -> "Double"+  GenFloat   -> "Float"+  GenHalf    -> "Half"+  GenInt     -> "Int"+  GenLong    -> "Long"+  GenShort   -> "Short"+  GenNothing -> ""+++type2accreal :: LibType -> TemplateType -> Text+type2accreal lt t = case signatureAliases lt t of+  Just (_, _, CAccReal hs _, _) -> stripModule hs+  Nothing -> "" -- impossible "TemplateType is concrete and should not have been called"+++tensorMathCases :: LibType -> HashMap FunctionName (HashSet TemplateType)+tensorMathCases _ =+  [ ("abs",     [GenShort, GenInt, GenLong, GenFloat, GenDouble])+  , ("sigmoid", [GenFloat, GenDouble])+  , ("log",     [GenFloat, GenDouble])+  , ("lgamma",  [GenFloat, GenDouble])+  , ("log1p",   [GenFloat, GenDouble])+  , ("exp",     [GenFloat, GenDouble])+  , ("erf",     [GenFloat, GenDouble])+  , ("erfinv",  [GenFloat, GenDouble])+  , ("cos",     [GenFloat, GenDouble])+  , ("acos",    [GenFloat, GenDouble])+  , ("cosh",    [GenFloat, GenDouble])+  , ("sin",     [GenFloat, GenDouble])+  , ("asin",    [GenFloat, GenDouble])+  , ("sinh",    [GenFloat, GenDouble])+  , ("tan",     [GenFloat, GenDouble])+  , ("atan",    [GenFloat, GenDouble])+  , ("atan2",   [GenFloat, GenDouble])+  , ("tanh",    [GenFloat, GenDouble])+  , ("pow",     [GenFloat, GenDouble])+  , ("tpow",    [GenFloat, GenDouble])+  , ("sqrt",    [GenFloat, GenDouble])+  , ("rsqrt",   [GenFloat, GenDouble])+  , ("ceil",    [GenFloat, GenDouble])+  , ("floor",   [GenFloat, GenDouble])+  , ("round",   [GenFloat, GenDouble])+  , ("trunc",   [GenFloat, GenDouble])+  , ("frac",    [GenFloat, GenDouble])+  , ("lerp",    [GenFloat, GenDouble])+  , ("mean",    [GenFloat, GenDouble])+  , ("std",     [GenFloat, GenDouble])+  , ("var",     [GenFloat, GenDouble])+  , ("norm",    [GenFloat, GenDouble])+  , ("renorm",  [GenFloat, GenDouble])+  , ("dist",    [GenFloat, GenDouble])+  , ("histc",   [GenFloat, GenDouble])+  , ("bhistc",  [GenFloat, GenDouble])+  , ("meanall", [GenFloat, GenDouble])+  , ("varall",  [GenFloat, GenDouble])+  , ("stdall",  [GenFloat, GenDouble])+  , ("normall", [GenFloat, GenDouble])+  , ("linspace",[GenFloat, GenDouble])+  , ("logspace",[GenFloat, GenDouble])+  , ("rand",    [GenFloat, GenDouble])+  , ("randn",   [GenFloat, GenDouble])+  , ("logicalall", [GenByte])+  , ("logicalany", [GenByte])++  -- cinv doesn't seem to be excluded by the preprocessor, yet is not+  -- implemented for Int. TODO - file issue report?+  , ("cinv", [GenFloat, GenDouble])+  , ("neg",  [GenFloat, GenDouble, GenLong, GenShort, GenInt])+  ]++tensorRandomCases :: LibType -> HashMap FunctionName (HashSet TemplateType)+tensorRandomCases _ =+  [ ("uniform",        [GenFloat, GenDouble])+  , ("normal",         [GenFloat, GenDouble])+  , ("normal_means",   [GenFloat, GenDouble])+  , ("normal_stddevs", [GenFloat, GenDouble])+  , ("normal_means_stddevs", [GenFloat, GenDouble])+  , ("exponential",    [GenFloat, GenDouble])+  , ("standard_gamma", [GenFloat, GenDouble])++  , ("digamma",        [GenFloat, GenDouble])+  , ("trigamma",       [GenFloat, GenDouble])+  , ("polygamma",      [GenFloat, GenDouble])+  , ("expm1",          [GenFloat, GenDouble])+  , ("dirichlet_grad", [GenFloat, GenDouble])+  , ("cauchy",         [GenFloat, GenDouble])+  , ("logNormal",      [GenFloat, GenDouble])+  , ("multinomial",    [GenFloat, GenDouble])+  , ("multinomialAliasSetup", [GenFloat, GenDouble])+  , ("multinomialAliasDraw",  [GenFloat, GenDouble])++  , ("getRNGState", [GenByte])+  , ("setRNGState", [GenByte])++  -- This keeps appearing but isn't in TH. TODO: find out what is happening+  , ("bernoulli_Tensor", [])+  ]+++-- TODO: check lapack bindings - not obvious from source, but there are+-- problems loading shared library with these functions for Byte+tensorLapackCases :: LibType -> HashMap FunctionName (HashSet TemplateType)+tensorLapackCases _ =+  [ ("gesv",   [GenFloat, GenDouble])+  , ("trtrs",  [GenFloat, GenDouble])+  , ("gels",   [GenFloat, GenDouble])+  , ("syev",   [GenFloat, GenDouble])+  , ("geev",   [GenFloat, GenDouble])+  , ("gesvd",  [GenFloat, GenDouble])+  , ("gesvd2", [GenFloat, GenDouble])+  , ("getrf",  [GenFloat, GenDouble])+  , ("getrs",  [GenFloat, GenDouble])+  , ("getri",  [GenFloat, GenDouble])+  , ("potrf",  [GenFloat, GenDouble])+  , ("potrs",  [GenFloat, GenDouble])+  , ("potri",  [GenFloat, GenDouble])+  , ("qr",     [GenFloat, GenDouble])+  , ("geqrf",  [GenFloat, GenDouble])+  , ("orgqr",  [GenFloat, GenDouble])+  , ("ormqr",  [GenFloat, GenDouble])+  , ("pstrf",  [GenFloat, GenDouble])+  , ("btrifact",  [GenFloat, GenDouble])+  , ("btrisolve", [GenFloat, GenDouble])+  -- , ("geev", [GenFloat, GenDouble])+  -- , ("gels", [GenFloat, GenDouble])+  -- , ("gesv", [GenFloat, GenDouble])+  -- , ("gesvd", [GenFloat, GenDouble])+  ]++storageCases :: LibType -> HashMap FunctionName (HashSet TemplateType)+storageCases _ =+  [ ("elementSize", [])+  ]++storageCopyCases :: LibType -> HashMap FunctionName (HashSet TemplateType)+storageCopyCases THC =+  [ ("copyCudaHalf", [GenHalf])+  ]+storageCopyCases _ = mempty++tensorBlasCases :: LibType -> HashMap FunctionName (HashSet TemplateType)+tensorBlasCases THC =+  [ ("dot", [GenFloat, GenDouble])+  , ("addmv", [GenFloat, GenDouble])+  , ("addmm", [GenFloat, GenDouble])+  , ("addr", [GenFloat, GenDouble])+  , ("addbmm", [GenFloat, GenDouble])+  , ("baddbmm", [GenFloat, GenDouble])+  ]+tensorBlasCases _ = mempty++++checkMath :: LibType -> TemplateType -> FunctionName -> Bool+checkMath = checkMap tensorMathCases++checkRandom :: LibType -> TemplateType -> FunctionName -> Bool+checkRandom = checkMap tensorRandomCases++checkLapack :: LibType -> TemplateType -> FunctionName -> Bool+checkLapack = checkMap tensorLapackCases++checkStorage :: LibType -> TemplateType -> FunctionName -> Bool+checkStorage = checkMap storageCases++checkStorageCopy :: LibType -> TemplateType -> FunctionName -> Bool+checkStorageCopy = checkMap storageCopyCases++checkTensorBlasCases :: LibType -> TemplateType -> FunctionName -> Bool+checkTensorBlasCases = checkMap tensorBlasCases++checkMap+  :: (LibType -> HashMap FunctionName (HashSet TemplateType))+  -> LibType+  -> TemplateType+  -> FunctionName+  -> Bool+checkMap map lt tt n = maybe True (tt `S.member`) (M.lookup n (map lt))+++-- | Warning a function that doesn't exist will return True by default+--+-- TODO: make this safer.+-- (stites): to make this safer I think we need to invert these maps so that we+--           are given function names instead of doing membership checks.+checkFunction :: LibType -> TemplateType -> FunctionName -> Bool+checkFunction lt tt fn+  =  checkMath   lt tt fn+  && checkRandom lt tt fn+  && checkLapack lt tt fn+  && checkStorage lt tt fn+  && checkStorageCopy lt tt fn+  && checkTensorBlasCases lt tt fn++test :: IO ()+test = do+  print $ checkFunction TH GenByte  "logicalany"+  print $ checkFunction TH GenFloat "logicalany"+  print $ checkFunction TH GenByte  "multinomial"+  print $ checkFunction TH GenFloat "multinomial"
+ src/CodeGen/Prelude.hs view
@@ -0,0 +1,38 @@+module CodeGen.Prelude+  ( module X+  , impossible+  , tshow+  , tputStrLn+  ) where++import Prelude         as X+import Control.Monad   as X (guard, void)+import Control.Monad.IO.Class as X (liftIO)+import Data.Char       as X (toLower)+import Data.Either     as X (either)+import Data.Foldable   as X (asum)+import Data.Hashable   as X (Hashable)+import Data.HashMap.Strict as X (HashMap)+import Data.HashSet        as X (HashSet)+import Data.List       as X (nub, intercalate)+import Data.Maybe      as X (fromMaybe, mapMaybe, catMaybes, isJust, Maybe)+import Data.Monoid     as X ((<>))+import Data.Text       as X (Text)+import Data.Void       as X (Void)+import Debug.Trace     as X+import Text.Megaparsec as X+  (ParseError, runParser, Parsec, ParsecT, (<|>), choice, lookAhead, try, some, skipMany, optional, eof, many, atEnd)+import Text.Megaparsec.Char as X+import GHC.Exts        as X (IsString(..))+import GHC.Generics    as X (Generic)++import qualified Data.Text as T++impossible :: Show msg => msg -> a+impossible x = error (show x)++tshow :: Show t => t -> Text+tshow = T.pack . show++tputStrLn :: Text -> IO ()+tputStrLn = putStrLn . T.unpack
+ src/CodeGen/Render.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE NamedFieldPuns #-}+module CodeGen.Render+  ( makeModule+  , writeHaskellModule++  , parseFile+  , cleanList++  , renderFunctions+  ) where++import Control.Monad (join)+import Control.Arrow ((&&&))+import CodeGen.Prelude+import Data.List+import System.Directory (createDirectoryIfMissing)+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.Text as T++import CodeGen.Types+import CodeGen.Render.Function (renderSig, SigType(..), mkHsname)+import CodeGen.Parse.Cases (checkFunction, type2hsreal)+import qualified CodeGen.Parse as CG (parser)+++-- ----------------------------------------+-- helper data and functions for templating+-- ----------------------------------------++renderExtensions :: [Text] -> Text+renderExtensions extensions = T.intercalate "\n" (extensions' <> [""])+ where+  extensions' :: [Text]+  extensions' = renderExtension <$> extensions++  renderExtension :: Text -> Text+  renderExtension extension = "{-# LANGUAGE " <> extension <> " #-}"++renderModule :: HModule -> Text+renderModule m+  = "module "+  <> outModule (lib m)+  <> generatedTypeModule+  <> (case basename of+         "" -> ""+         _  -> "." <> basename)+ where+  basename :: Text+  basename = textFileSuffix (fileSuffix m)++  generatedTypeModule :: Text+  generatedTypeModule = case isTemplate m of+    ConcreteFiles -> ""+    GenericFiles -> "." <> type2hsreal (typeTemplate m)++renderExports :: [Text] -> Text+renderExports _ = " where\n\n"++renderImports :: [Text] -> Text+renderImports imports = T.intercalate "\n" (("import " <>) <$> imports) <> "\n\n"+++renderFunctions :: HModule -> [(Maybe (LibType, Text), Function)] -> Text+renderFunctions m validFunctions =+  T.intercalate "\n\n"+    $  (renderSig'    IsFun <$> remainder)+    <> (renderSig' IsFunPtr <$> remainder)+ where+  renderSig' t = renderSig t (lib m) (isTemplate m) (header m) (typeTemplate m) (suffix m) (fileSuffix m)++  remainder :: [(Maybe (LibType, Text), Text, Parsable, [Arg])]+  remainder = go <$> validFunctions+    where+      go :: (Maybe (LibType, Text), Function) -> (Maybe (LibType, Text), Text, Parsable, [Arg])+      go (mp, f) = (mp, funName f, funReturn f, funArgs f)+++validFunctions :: LibType -> [Function] -> TemplateType -> [(Maybe (LibType, Text), Function)]+validFunctions lt fs tt+  -- ensure that everything is unique (while maintaining the rendered order)+  = nub++  -- use a prefix if the function prefix/namespace doesn't line up with the current module+  $ map ((join . fmap checkLibs . funPrefix) &&& id)++  -- filter any functions which don't belong+  $ filter (checkFunction lt tt . FunctionName . funName) fs++ where+  checkLibs :: (LibType, Text) -> Maybe (LibType, Text)+  checkLibs pref = do+    guard (lt /= fst pref)+    pure pref+++renderAll :: HModule -> Text+renderAll m+  =  renderExtensions (extensions m)+  <> renderModule m+  <> renderExports exportFunctions+  <> renderImports (imports m)+  <> renderFunctions m validFunctions'+  where+    validFunctions' :: [(Maybe (LibType, Text), Function)]+    validFunctions' = validFunctions (lib m) (bindings m) (typeTemplate m)++    fun2name :: SigType -> (Maybe (LibType, Text), Function) -> Text+    fun2name st (mp, fn) = mkHsname (lib m) st mp (funName fn)++    exportFunctions :: [Text]+    exportFunctions+      =  fmap (fun2name IsFun)    validFunctions'+      <> fmap (fun2name IsFunPtr) validFunctions'++writeHaskellModule+  :: [Function]+  -> (TemplateType -> [Function] -> HModule)+  -> TemplateType+  -> IO ()+writeHaskellModule parsedBindings makeConfig templateType+  | numFunctions == 0 =+    tputStrLn $ "No bindings found for " <> outDir <> filename++  | otherwise = do+    tputStrLn $ "Writing " <> outDir <> filename+    createDirectoryIfMissing True (T.unpack outDir)+    writeFile (T.unpack $ outDir <> filename) (T.unpack . renderAll $ modSpec)+ where+  modSpec :: HModule+  modSpec = makeConfig templateType parsedBindings++  basename :: Text+  basename = textFileSuffix (fileSuffix modSpec)++  filename :: Text+  filename = case basename of+    "" -> type2hsreal templateType <> ".hs"+    bn -> bn <> ".hs"++  outDir :: Text+  outDir =+    case basename of+     "" -> textPath (modOutDir modSpec) <> "/"+     _  -> textPath (modOutDir modSpec) <> "/" <> type2hsreal templateType <> "/"++  numFunctions :: Int+  numFunctions = length $ validFunctions (lib modSpec) (bindings modSpec) (typeTemplate modSpec)++-- ----------------------------------------+-- Execution+-- ----------------------------------------++-- | Remove if list was returned, extract non-Nothing values, o/w empty list+cleanList :: Either (ParseError Char Void) [Maybe Function] -> [Function]+cleanList = either (const []) catMaybes++parseFile :: LibType -> CodeGenType -> String -> IO [Function]+parseFile _ _ file = do+  putStrLn $ "\nParsing " ++ file ++ " ... "+  res <- parseFromFile CG.parser file+  pure $ cleanList res+ where+  parseFromFile+    :: Parser [Maybe Function]+    -> String+    -> IO (Either (ParseError Char Void) [Maybe Function])+  parseFromFile p file = runParser p file <$> readFile file+
+ src/CodeGen/Render/C.hs view
@@ -0,0 +1,55 @@+module CodeGen.Render.C+  ( render+  , renderTenType+  , renderCType+  -- , renderNNType+  ) where++import CodeGen.Prelude+import CodeGen.Types++render :: Parsable -> Text+render =+  \case+    -- special pointer cases+    Ptr x -> render x <> " *"+    TenType x -> renderTenType x+    -- NNType x -> renderNNType lt x+    CType x -> renderCType x+++renderTenType :: TenType -> Text+renderTenType = \case+  Pair (Real, _)    -> "real"+  Pair (AccReal, _) -> "accreal"+  p@(Pair (rtt, lib)) -> (if isConcreteCudaPrefixed p then "THCuda" else tshow lib) <> tshow rtt+++renderCType :: CType -> Text+renderCType = \case+  CUInt64  -> "uint64_t"+  CUInt32  -> "uint32_t"+  CUInt16  -> "uint16_t"+  CUInt8   -> "uint8_t"++  CInt64   -> "int64_t"+  CInt32   -> "int32_t"+  CInt16   -> "int16_t"+  CInt8    -> "int8_t"+  CInt     -> "int"++  CSize    -> "size_t"+  CLong    -> "long"+  CChar    -> "char"+  CShort   -> "short"+  CFloat   -> "float"+  CDouble  -> "double"+  CPtrdiff -> "ptrdiff_t"+  CVoid    -> "void"+  CBool    -> "bool"+++-- -- FIXME: get back to this when THC is finished+-- renderNNType :: LibType -> NNType -> Text+-- renderNNType lt nt = tshow lt <> tshow nt+
+ src/CodeGen/Render/Function.hs view
@@ -0,0 +1,162 @@+module CodeGen.Render.Function+  ( renderSig+  , haskellSig+  , mkHsname+  , SigType(..)+  ) where++import CodeGen.Prelude+import CodeGen.Types+import CodeGen.Parse.Cases (type2hsreal)+import Control.Arrow ((&&&))+import qualified CodeGen.Render.C as C (render)+import qualified CodeGen.Render.Haskell as Hs (render)+import qualified Data.Char as Ch (toUpper)+import qualified Data.Text as T++data SigType+  = IsFun+  | IsFunPtr+  deriving (Eq, Ord, Show)++ffiPrefix :: SigType -> Text+ffiPrefix = \case+  IsFun    -> "c_"+  IsFunPtr -> "p_"++isPtr :: SigType -> Bool+isPtr f = f == IsFunPtr++comment :: LibType -> SigType -> Text -> [Arg] -> Parsable -> Text+comment lt t hsname args retType = T.intercalate " "+  $  [ "-- |" , hsname , ":", if isPtr t then "Pointer to function :" else "" ]+  <> map argName args+  <> (if null args then [] else ["->"])+  <> [C.render retType]++foreignCall :: Text -> FilePath -> Text+foreignCall cname headerFile = T.intercalate "\""+  [ "foreign import ccall "+  , T.pack headerFile <> cname+  , ""+  ]++haskellSig :: LibType -> Text -> SigType -> TemplateType -> [Arg] -> Parsable -> Text+haskellSig lt hsname st tt args retType = T.intercalate ""+  [ hsname+  , " :: "+  , if isPtr st then "FunPtr (" else ""+  , T.intercalate " -> " typeSignature, retArrow+  , if isPtr st then ")" else ""+  ]+ where+  typeSignature :: [Text]+  typeSignature = case args of+    [Arg (CType CVoid) _] -> []+    args' -> mapMaybe (Hs.render FunctionParam tt . argType) args'++  retArrow :: Text+  retArrow = case Hs.render ReturnValue tt retType of+    Nothing  -> ""+    Just ret -> if null typeSignature then ret else (" -> " <> ret)+++mkCname+  :: SigType -> LibType -> ModuleSuffix -> TemplateType -> CodeGenType -> Maybe (LibType, Text) -> Text -> Text+mkCname st lt ms tt cgt mpref funname+  = (if isPtr st then " &" else " ")+  <> identifier+  <> funname+ where+  identifier :: Text+  identifier = case cgt of+    ConcreteFiles -> ""+    GenericFiles ->+      case lt of+        TH     -> "TH"        <> type2hsreal tt <> textSuffix ms <> "_"+        THNN   -> "THNN_"     <> type2hsreal tt+        THCUNN -> "THNN_Cuda" <> type2hsreal tt+        THC -> case mpref of+          -- THC is the only library that has this+          Nothing       -> prefix lt  (isTHCTensor lt ) <> type2hsreal tt <> textSuffix ms <> "_"+          Just (lt', t) -> prefix lt' (isTHCTensor lt') <> type2hsreal tt <> t <> "_"+         where+          isTHCTensor :: LibType -> Bool+          isTHCTensor lt =+            (  textSuffix ms == "Tensor"+            || textSuffix ms == "Storage"+            || textSuffix ms == "TensorMath")++-- | render a haskell function name.+mkHsname :: LibType -> SigType -> Maybe (LibType, Text) -> Text -> Text+mkHsname lt st mpref funname =+  case lt of+    THCUNN -> ffiPrefix st <> funname+    _ -> case mpref of+      Nothing       -> ffiPrefix st <> funname+      Just (lt', _) -> ffiPrefix st <> (if lt' == lt then funname else newName lt')+ where+   newName :: LibType -> Text+   newName lt' = (T.toLower (tshow lt') <>) $ uncurry T.cons $ ((Ch.toUpper . T.head) &&& T.tail) funname+++-- | Render a single function signature.+renderSig+  :: SigType+  -> LibType+  -> CodeGenType+  -> FilePath+  -> TemplateType+  -> ModuleSuffix+  -> FileSuffix+  -> (Maybe (LibType, Text), Text, Parsable, [Arg])+  -> Text+renderSig st lt cgt headerFile tt ms fs (mpref, name, retType, args) =+  T.intercalate "\n"+    [ comment lt st hsname args retType+    , foreignCall cname headerFile+    , implementation+    ]+ where+  cname, hsname :: Text+  cname = mkCname st lt ms tt cgt mpref name+  hsname = mkHsname lt st mpref name++  implementation :: Text+  implementation =+    case (lt, cgt, fs, st) of+      -- NOTE: TH and THC functions differ in the THC State. TH does have a concept of THState, which+      -- is unused. Here we render some function aliases which will allow us to maintain unified+      -- backpack signatures.+      --+      -- NOTE2: In the event that we render generic functions from the TH+      -- library which _does not include THTensorRandom_, we want to post-fix these names with a @_@+      -- and use the alias to match the backpack signatures.+      (TH, GenericFiles, _, IsFun) ->+        T.intercalate "\n"+          [ "  " <> (haskellSig lt (mkAliasRefName hsname) st tt args retType)+          , ""+          , "-- | alias of " <> mkAliasRefName hsname <> " with unused argument (for CTHState) to unify backpack signatures."+          , haskellSig lt hsname st tt thArgs retType+          , hsname <> " = const " <> mkAliasRefName hsname+          ]+        where+          -- | TH only (and even then only generic TH files).+          --+          -- 'reference' implying "original haskell function" and alias implying+          -- "backpack-compatible function" as well as "c-native function"+          mkAliasRefName :: Text -> Text+          mkAliasRefName = (<> "_")++          thArgs :: [Arg]+          thArgs =+            if length args == 1 && argType (head args) == (CType CVoid)+            then [statePtr]+            else statePtr:args++          statePtr :: Arg+          statePtr = Arg (Ptr (TenType (Pair (State, TH)))) "state"++      _ -> "  " <> (haskellSig lt hsname st tt args retType)++
+ src/CodeGen/Render/Haskell.hs view
@@ -0,0 +1,73 @@+module CodeGen.Render.Haskell+  ( render+  ) where++import CodeGen.Prelude+import CodeGen.Types+import CodeGen.Parse.Cases (type2hsreal, type2real, type2accreal)+import qualified Data.Text as T+++render :: TypeCategory -> TemplateType -> Parsable -> Maybe Text+render tc tt = typeCatHelper tc . renderParsable tt+++typeCatHelper :: TypeCategory -> Text -> Maybe Text+typeCatHelper tc s = case tc of+  FunctionParam -> Just s+  ReturnValue   ->+    case T.take 3 s of+     "()"  -> Just   "IO ()"+     "Ptr" -> Just $ "IO (" <> s <> ")"+     _     -> Just $ "IO " <> s <> ""+++renderParsable :: TemplateType -> Parsable -> Text+renderParsable tt =+  \case+    -- special cases+    TenType desc@(Pair (DescBuff, _)) -> "Ptr " <> renderTenType tt desc++    Ptr (Ptr x) -> "Ptr (Ptr " <> renderParsable tt x <> ")"+    Ptr x -> "Ptr " <> renderParsable tt x+    -- Raw DescBuffs need to be wrapped in a pointer for marshalling+    TenType x -> renderTenType tt x+    -- NNType x -> renderNNType lt tt x+    CType x -> renderCType x+++renderTenType :: TemplateType -> TenType -> Text+renderTenType tt = \case+  Pair (Tensor,  lt) -> c <> prefix lt True <> type2hsreal tt <> "Tensor"+  Pair (Storage, lt) -> c <> tshow lt       <> type2hsreal tt <> "Storage"+  Pair (Real,    lt) -> type2real lt tt+  Pair (AccReal, lt) -> type2accreal lt tt+  r@(Pair (rtt, lt)) -> c <> prefix lt (isConcreteCudaPrefixed r) <> tshow rtt+ where+  c = "C'"+++renderCType :: CType -> Text+renderCType = \case+  CVoid -> "()"+  -- int/uint conversions, see+  -- https://www.haskell.org/onlinereport/haskell2010/haskellch8.html+  -- https://hackage.haskell.org/package/base-4.10.0.0/docs/Foreign-C-Types.html+  CUInt64 -> "CULong"+  CUInt32 -> "CUInt"+  CUInt16 -> "CUShort"+  CUInt8  -> "CUChar"+  CInt64  -> "CLLong"+  CInt32  -> "CInt"+  CInt16  -> "CShort"+  CInt8   -> "CSChar"+  rest    -> tshow rest++{-+-- FIXME: get back to this when THC is finished+renderNNType :: LibType -> TemplateType -> NNType -> Text+renderNNType _ _ = \case+  IndexTensor   -> undefined+  IntegerTensor -> undefined+-}+
+ src/CodeGen/Types.hs view
@@ -0,0 +1,11 @@+module CodeGen.Types+  ( module CodeGen.Types.HsOutput+  , module CodeGen.Types.Parsed+  , module CodeGen.Types.CLI+  ) where++import CodeGen.Types.HsOutput+import CodeGen.Types.Parsed+import CodeGen.Types.CLI++
+ src/CodeGen/Types/CLI.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}+module CodeGen.Types.CLI+  ( LibType(..)+  , prefix+  , describe'+  , supported+  , supportedLibraries+  , outDir+  , outModule+  , srcDir+  , CodeGenType(..)+  , generatable+  , TemplateType(..)+  , generatedTypes+  ) where++import Data.Data+import Data.Typeable+import CodeGen.Prelude+import qualified Data.Text as T+import qualified Data.HashSet as HS+++-- | All possible libraries that we intend to support (these are all src+-- libraries in ATen). Note that this ordering is used in codegen and must not be changed.+data LibType+  = ATen+  | THCUNN+  | THCS+  | THC+  | THNN+  | THS+  | TH+  deriving (Eq, Ord, Show, Enum, Bounded, Read, Generic, Hashable, Data, Typeable)+++prefix :: LibType -> Bool -> Text+prefix lt long =+  case lt of+    THC    -> if long then "THCuda" else "THC"+    THCUNN -> if long then "THCuda" else "THC"+    _   -> tshow lt+++-- | Short descriptions of each library we intend to support.+describe' :: LibType -> String+describe' = \case+  ATen -> "A simple TENsor library thats exposes the Tensor operations in Torch"+       ++ "and PyTorch directly in C++11."+  TH -> "Torch7"+  THC -> "Cuda-based Torch7"+  THCS -> "Cuda-based Sparse Tensor support with TH"+  THCUNN -> "Cuda-based THNN"+  THNN -> "THNN"+  THS -> "TH Sparse tensor support (ATen library)"+++-- | Whether or not we currently support code generation for the library+supported :: LibType -> Bool+supported lt = lt `HS.member` HS.fromList [TH, THC, THNN, THCUNN]++supportedLibraries :: [LibType]+supportedLibraries = filter supported [minBound..maxBound]++-- | Where generated code will be placed.+outDir :: LibType -> FilePath+outDir lt = intercalate ""+  [ "output/raw/"+  , toLowers lt ++ "/"+  , "src/"+  , T.unpack (out "/" lt)+  ]++toLowers :: Show a => a -> String+toLowers = map toLower . show++-- | The prefix of the output module name+outModule :: LibType -> Text+outModule = out "."++out :: Text -> LibType -> Text+out x = \case+  THCUNN -> go2 THC+  THNN   -> go2 TH+  rest   -> go1 rest+ where+  go1 lt = T.intercalate x ["Torch","FFI", tshow lt]+  go2 lt = T.intercalate x ["Torch","FFI", tshow lt, "NN"]+++-- | Where the source files are located, relative to the root of the hasktorch+-- project.+srcDir :: LibType -> CodeGenType -> FilePath+srcDir lt cgt = intercalate ""+  [ "./deps/aten/src/"+  , show lt ++ "/"+  , if cgt == GenericFiles then "generic/" else ""+  ]+++-- | Type of code to generate+data CodeGenType+  = GenericFiles   -- ^ generic/ files which are used in C for type-generic code+  | ConcreteFiles  -- ^ concrete supporting files. These include utility+                   --   functions and random generators.+  deriving (Eq, Ord, Enum, Bounded)++instance Read CodeGenType where+  readsPrec _ s = case s of+    "generic"  -> [(GenericFiles, "")]+    "concrete" -> [(ConcreteFiles, "")]+    _          -> []++instance Show CodeGenType where+  show = \case+    GenericFiles  -> "generic"+    ConcreteFiles -> "concrete"+++-- | Whether or not we currently support generating this type of code (ie: I+-- (\@stites) am not sure about the managed files).+generatable :: CodeGenType -> Bool+generatable = const True++-- ----------------------------------------+-- Types for representing templating+-- ----------------------------------------++data TemplateType+  = GenByte+  | GenChar+  | GenDouble+  | GenFloat+  | GenHalf+  | GenInt+  | GenLong+  | GenShort+  | GenNothing+  deriving (Eq, Ord, Bounded, Show, Generic, Hashable)+++-- List used to iterate through all template types+generatedTypes :: LibType -> CodeGenType -> [TemplateType]+generatedTypes THNN   = \case { ConcreteFiles -> [GenNothing]; GenericFiles -> [GenDouble, GenFloat] }+generatedTypes THCUNN = \case { ConcreteFiles -> [GenNothing]; GenericFiles -> [GenDouble, GenFloat] }+generatedTypes _ = \case+  ConcreteFiles -> [GenNothing]+  GenericFiles ->+    [ GenByte+    , GenChar+    , GenDouble+    , GenFloat+    , GenHalf+    , GenInt+    , GenLong+    , GenShort+    ]+
+ src/CodeGen/Types/HsOutput.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module CodeGen.Types.HsOutput+  ( HModule(..)+  , ModuleSuffix(..)+  , FileSuffix(..)+  , TextPath(..)+  , makeModule++  , TypeCategory(..)++  , FunctionName(..)++  , CRep(..)+  , HsRep(..)+  , stripModule++  , CTensor(..)+  , CReal(..)+  , CAccReal(..)+  , CStorage(..)++  , HasAlias(..)+  ) where++import CodeGen.Prelude+import CodeGen.Types.CLI+import CodeGen.Types.Parsed+import Data.Semigroup hiding ((<>))+import qualified Data.Text as T++++-- ----------------------------------------+-- Types for rendering output+-- ----------------------------------------++data HModule = HModule+  { lib          :: LibType+  , extensions   :: [Text]+  , imports      :: [Text]+  , typeDefs     :: [(Text, Text)]+  , header       :: FilePath+  , typeTemplate :: TemplateType+  , suffix       :: ModuleSuffix+  , fileSuffix   :: FileSuffix+  , bindings     :: [Function]+  , modOutDir    :: TextPath+  , isTemplate   :: CodeGenType+  } deriving Show++newtype ModuleSuffix = ModuleSuffix { textSuffix :: Text }+  deriving newtype (IsString, Semigroup, Monoid, Ord, Read, Eq, Show)++newtype FileSuffix = FileSuffix { textFileSuffix :: Text }+  deriving newtype (IsString, Semigroup, Monoid, Ord, Read, Eq, Show)++newtype TextPath = TextPath { textPath :: Text }+  deriving newtype (IsString, Semigroup, Monoid, Ord, Read, Eq, Show)++makeModule+  :: LibType+  -> TextPath+  -> CodeGenType+  -> FilePath+  -> ModuleSuffix+  -> FileSuffix+  -> TemplateType+  -> [Function]+  -> HModule+makeModule lt a0 a1 a2 a3 a4 a5 a6+  = HModule+  { lib = lt+  , extensions = ["ForeignFunctionInterface"]+  , imports = ["Foreign", "Foreign.C.Types", "Data.Word", "Data.Int"] <> torchtypes+  , typeDefs = []+  , modOutDir = a0+  , isTemplate = a1+  , header = a2+  , suffix = a3+  , fileSuffix = a4+  , typeTemplate = a5+  , bindings = a6+  }+ where+  torchtypes :: [Text]+  torchtypes = case lt of+    THC    -> go [TH, THC]+    THCUNN -> go [TH, THC]+    THNN   -> go [TH]+    rest   -> go [rest]+    where+      go :: [LibType] -> [Text]+      go ls = (("Torch.Types." <>) . tshow) <$> ls+++data TypeCategory+  = ReturnValue+  | FunctionParam++-------------------------------------------------------------------------------++-- | a concrete type for function names+newtype FunctionName = FunctionName Text+  deriving stock (Show, Eq, Ord)+  deriving newtype (IsString, Hashable)++newtype CRep = CRep Text+  deriving stock (Show, Eq, Ord)+  deriving newtype (IsString, Hashable)++newtype HsRep = HsRep Text+  deriving stock (Show, Eq, Ord)+  deriving newtype (IsString, Hashable)++stripModule :: HsRep -> Text+stripModule (HsRep t) = T.takeWhileEnd (/= '.') t++data CTensor  = CTensor  HsRep CRep+  deriving (Eq, Ord, Generic, Hashable, Show)++data CReal    = CReal    HsRep CRep+  deriving (Eq, Ord, Generic, Hashable, Show)++data CAccReal = CAccReal HsRep CRep+  deriving (Eq, Ord, Generic, Hashable, Show)++data CStorage = CStorage HsRep CRep+  deriving (Eq, Ord, Generic, Hashable, Show)++-- ========================================================================= --++class HasAlias t where+  alias :: t -> Text++instance HasAlias CTensor  where alias (CTensor t _)  = _alias "CTensor" t+instance HasAlias CReal    where alias (CReal t _)    = _alias "CReal" t+instance HasAlias CAccReal where alias (CAccReal t _) = _alias "CAccReal" t+instance HasAlias CStorage where alias (CStorage t _) = _alias "CStorage" t++_alias :: Text -> HsRep -> Text+_alias a (HsRep t) = T.intercalate " " ["type", a, "=", t]++
+ src/CodeGen/Types/Parsed.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+module CodeGen.Types.Parsed where++import CodeGen.Prelude+import CodeGen.Types.CLI+import Control.Monad+import Data.Data+import Data.Typeable+import qualified Data.HashSet as HS+++-- ----------------------------------------+-- Parsed types+-- ----------------------------------------+data Parsable+  = Ptr Parsable+  | TenType TenType+  -- | NNType NNType+  | CType CType+  deriving (Eq, Show, Generic, Hashable)++data CType+  = CBool+  | CVoid+  | CPtrdiff+  | CFloat+  | CDouble+  | CLong++  | CUInt64+  | CUInt32+  | CUInt16+  | CUInt8++  | CInt64+  | CInt32+  | CInt16+  | CInt8++  | CInt -- must come _after_ all the other int types++  | CSize+  | CChar+  | CShort+  deriving (Eq, Show, Generic, Hashable, Bounded, Enum)++newtype TenType = Pair { unTenType :: (RawTenType, LibType) }+  deriving (Eq, Show, Generic, Hashable)++data RawTenType+  = Tensor+  | ByteTensor+  | CharTensor+  | ShortTensor+  | IntTensor+  | LongTensor+  | FloatTensor+  | DoubleTensor+  | HalfTensor++  | Storage+  | ByteStorage+  | CharStorage+  | ShortStorage+  | IntStorage+  | LongStorage+  | FloatStorage+  | DoubleStorage+  | HalfStorage++  | DescBuff+  | Generator+  | Allocator+  | File+  | Half+  | State++  -- NN types+  | IndexTensor+  | IntegerTensor++  -- real and accreal are parameterized occasionally differ by library, but I don't think this exists to date.+  | Real+  | AccReal++  -- FIXME: I don't think we need to enable THCThreadLocal, yet. But we would need to include a+  -- wrapper of ThreadId from the pthread package: https://hackage.haskell.org/package/pthread-0.2.0+  -- | ThreadLocal  -- THC-specific++  -- FIXME: while we can add this to codegen now, we need access to cudaStream_t in cuda_runtime_api+  | Stream  -- THC-specific+  deriving (Eq, Show, Generic, Hashable, Bounded, Enum)+++isConcreteCudaPrefixed :: TenType -> Bool+isConcreteCudaPrefixed (Pair (t, lib)) = (lib == THC || lib == THCUNN) && t `HS.member` HS.fromList+  [ ByteTensor+  , CharTensor+  , ShortTensor+  , IntTensor+  , LongTensor+  , FloatTensor+  , DoubleTensor+  , HalfTensor+  -- , IndexTensor+  ]++allTenTypes :: [TenType]+allTenTypes = Pair <$> ((,) <$> [minBound..maxBound] <*> [minBound..maxBound])++-- data NNType+--   = IndexTensor+--   | IntegerTensor+--   deriving (Eq, Show, Generic, Hashable, Bounded, Enum)+++data Arg = Arg+  { argType :: Parsable+  , argName :: Text+  } deriving (Eq, Show, Generic, Hashable)+++data Function = Function+  { funPrefix :: Maybe (LibType, Text)+  , funName   :: Text+  , funArgs   :: [Arg]+  , funReturn :: Parsable+  } deriving (Eq, Show, Generic, Hashable)++type Parser = Parsec Void String++
+ tests/CodeGen/Instances.hs view
@@ -0,0 +1,17 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module CodeGen.Instances where++import Test.QuickCheck++import CodeGen.Types++instance Arbitrary LibType where+  arbitrary = arbitraryBoundedEnum++instance Arbitrary RawTenType where+  arbitrary = arbitraryBoundedEnum++instance Arbitrary TenType where+  arbitrary = fmap Pair $ (,)+    <$> arbitrary+    <*> arbitrary
+ tests/CodeGen/ParseSpec.hs view
@@ -0,0 +1,420 @@+{-# LANGUAGE TupleSections #-}+module CodeGen.ParseSpec where++import Test.Hspec+import Text.Megaparsec hiding (runParser', State)+import CodeGen.Parse hiding (describe)+import CodeGen.Types hiding (describe)+import CodeGen.Prelude+import Data.List+import Data.Either+import Data.Maybe+import qualified Data.Text as T++import Debug.Trace+++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+  describe "the skip parser" skipSpec+  describe "the ptr parser" ptrSpec+  describe "the ptr2 parser" ptr2Spec+  describe "the ctypes parser" ctypesSpec+  describe "the functionArg parser" functionArgSpec+  describe "the functionArgs parser" functionArgsSpec+  describe "the function parser" functionSpec+  -- describe "running the full parser" $ do+  --   describe "in concrete mode" fullConcreteParser+  --   describe "in generic mode" fullGenericParser++runParser' p = runParser p "test"++testCGParser = runParser parser "test"+++succeeds :: (Show x, Eq x) => Parser x -> (String, x) -> IO ()+succeeds parser (str, res) = runParser' parser str `shouldBe` Right res+++fails :: (Show x, Eq x) => Parser x -> String -> IO ()+fails parser str = runParser' parser str `shouldSatisfy` isLeft+++fullConcreteParser :: Spec+fullConcreteParser = do+  it "should error if the header is first(??)" $+    testCGParser "TH_API \n" `shouldBe` Right [Nothing]++  it "should return Nothing if the API header" $+    testCGParser "foob TH_API \n" `shouldBe` Right [Nothing]++  it "should return a valid THFile function" $+    testCGParser thFileFunction `shouldBe` Right [Just thFileFunctionRendered]++  it "should return Nothing for declarations" $+    testCGParser "TH_API const double THLog2Pi;" `shouldBe` Right [Nothing]++  it "should return valid THLogAdd functions" $+    testCGParser thLogAddFunction `shouldBe` Right [Just thLogAddFunctionRendered]++  it "should return all functions in THFile" $+    thFileContents `fullFileTest` (155, 70, 70)+++fullGenericParser :: Spec+fullGenericParser = do+  it "should return valid types for the example string" $+    testCGParser exampleGeneric `shouldBe` Right [Just exampleGeneric']++  it "should return valid types for the example string with junk" $+    testCGParser (withAllJunk exampleGeneric) `shouldBe` Right [Nothing, Just exampleGeneric', Nothing, Nothing]++  it "should return all functions for THStorage" $+    thGenericStorageContents `fullFileTest` (86, 22, 22)++  it "should return all functions for THCTensorTopK" $+    thcGenericTensorTopKContents `fullFileTest` (10, 1, 1)++  it "should return valid types for THNN" $+    pendingWith "we don't currently support THNN"+++fullFileTest :: String -> (Int, Int, Int) -> Expectation+fullFileTest contents (all, found, uniq) = do+  let res = testCGParser contents+  res `shouldSatisfy` isRight+  let Right contents = res+  length contents `shouldSatisfy` (== all)+  length (catMaybes contents) `shouldSatisfy` (== found)+  length (nub $ catMaybes contents) `shouldSatisfy` (== uniq)+++skipSpec :: Spec+skipSpec = do+  it "finds the number of lines as \\n characters" $+    runSomeSkipOn "\n\n" `shouldSatisfy` foundNlines 2+  it "finds the number of lines in exampleGeneric" $+    runSomeSkipOn exampleGeneric `shouldSatisfy` foundNlines 1+  it "finds the number of lines in exampleGeneric withEndJunk" $+    runSomeSkipOn (withEndJunk exampleGeneric) `shouldSatisfy` foundNlines 2+  it "finds the number of lines in exampleGeneric withStartJunk" $+    runSomeSkipOn (withStartJunk exampleGeneric) `shouldSatisfy` foundNlines 2+  it "finds the number of lines in exampleGeneric withAllJunk" $+    runSomeSkipOn (withAllJunk exampleGeneric) `shouldSatisfy` foundNlines 3+ where+  foundNlines n = either (const False) ((== n) . length)+  runSomeSkipOn = runParser' (some skip)+++ptrSpec :: Spec+ptrSpec = do+  it "will parse pointers correctly"         $ mapM_ (succeeds ptr . (,())) [" * ", " *", "* ", "*"]+  it "will parse invalid pointers correctly" $ mapM_ (fails ptr)    [" ", ";*", "_* ", ""]+++ptr2Spec :: Spec+ptr2Spec = do+  it "will not parse single pointers" $ mapM_ (fails ptr2) [" * ", " *", "* ", "*"]+  it "will not parse invalid inputs"  $ mapM_ (fails ptr2) [" ", ";*", "_* ", ""]+  it "will parse double pointers" $ mapM_ (succeeds ptr2 . (,()))+    [ " ** " , " **" , "** " , "**" , " * * " , " * *" , "* * " , "* *"+    , " * * " , " * *" , "* * " , "* *", "**      ", "     ** ", "  *   * "+    ]+++ctypesSpec :: Spec+ctypesSpec = do+  describe "direct types" $+    it "renders happy path CTypes" $+      mapM_ (succeeds ctypes)+        [ ("uint64_t", CType CUInt64)+        , ("int", CType CInt)+        , ("int64_t", CType CInt64)+        , ("void", CType CVoid)+        ]++  describe "pointer ctypes" $+    it "renders happy path CType pointers" $+      mapM_ (succeeds ctypes)+        [ ("uint64_t *", Ptr (CType CUInt64))+        , ("int*", Ptr (CType CInt))+        , ("int64_t *", Ptr (CType CInt64))+        , ("void   *   ", Ptr (CType CVoid))+        ]++  describe "double-pointer ctypes" $+    it "renders happy path CType pointers of pointers" $+      mapM_ (succeeds ctypes)+        [ ("uint64_t * *", Ptr (Ptr (CType CUInt64)))+        , ("int**", Ptr (Ptr (CType CInt)))+        , ("int64_t **", Ptr (Ptr (CType CInt64)))+        , ("void   *   * ", Ptr (Ptr (CType CVoid)))+        ]+++functionArgSpec :: Spec+functionArgSpec = do+  let result = Right (Arg (CType CInt) "k")+  it "will find arguments with no name" $+    runParser' (char '(' >> functionArg) "(void)" `shouldBe` Right (Arg (CType CVoid) "")++  it "will find arguments with prefixed whitespaces" $+    runParser' functionArg "         int k)" `shouldBe` result++  it "will find arguments with comments" $+    runParser' functionArg "  int k, // foobar" `shouldBe` result++  describe "capturing arguments from THC's TensorTopK function" $ do+    it "captures `THCState* state,`" $+      runParser' functionArg "THCState* state," `shouldBe` Right (Arg (Ptr (TenType (Pair (State, THC)))) "state")+    it "captures `THCTensor* topK,`" $+      runParser' functionArg "THCTensor* topK," `shouldBe` Right (Arg (Ptr (TenType (Pair (Tensor, THC)))) "topK")+    it "captures `THCudaLongTensor*indices,`" $+      runParser' functionArg "THCudaLongTensor*indices," `shouldBe` Right (Arg (Ptr (TenType (Pair (LongTensor, THCUNN)))) "indices")+    it "captures `THCTensor* input,`" $+      runParser' functionArg "THCTensor* input," `shouldBe` Right (Arg (Ptr (TenType (Pair (Tensor, THC)))) "input")++functionArgsSpec :: Spec+functionArgsSpec = do+  let result = Right [Arg (CType CVoid) "", Arg (CType CInt) "foo"]+  it "will find arguments in newline-delineated lists" $+    runParser' functionArgs "(void,\n         int foo)" `shouldBe` result++  it "will find arguments in newline-delineated lists with spaces between command and newline" $+    runParser' functionArgs "(void,    \n         int foo)" `shouldBe` result++  it "will find arguments in newline-delineated lists with comments, v1" $+    runParser' functionArgs "(void,\n int foo //foobar\n)" `shouldBe` result++  it "will find arguments in newline-delineated lists with comments, v2" $+    runParser' functionArgs "(void,\n int foo //foobar\n    )" `shouldBe` result++  it "will find arguments in newline-delineated lists with comments, v3" $+    runParser' functionArgs "(void, //foobar \n int foo \n)" `shouldBe` result++  it "will find arguments in newline-delineated lists with comments, v4" $+    runParser' functionArgs "(void,//foobar\n int foo\n)" `shouldBe` result++  it "will find arguments in newline-delineated lists with comments which start with a newline" $+    runParser' functionArgs "(\nvoid,\n int foo //foobar\n)" `shouldBe` result++  it "will find arguments in newline-delineated lists from THCTensorTopK" $+    runParser' functionArgs thctensortopkArgs `shouldBe` Right (funArgs thcGenericTensorTopKFunction')+ where+  thctensortopkArgs = "(THCState* state,\n   THCTensor* topK,\n   THCudaLongTensor* "+    <> "indices,\n   THCTensor* input,\n  int64_t k, int dim, int dir, int sorted)"+++functionSpec :: Spec+functionSpec = do+  it "will find functions where the arguments have no name" $+    runParser' function storageElementSize `shouldBe` Right (Just storageElementSize')++  it "will find concrete THC functions in THCTensorRandom.h" $+    runParser' function thcRandomFunction `shouldBe` Right (Just thcRandomFunction')++  it "will find functions with arguments that span several lines (THCTensorTopK.h)" $+    runParser' function thcGenericTensorTopKFunction+      `shouldBe` Right (Just thcGenericTensorTopKFunction')++  describe "finding TH primatives in the generic/THCTensorCopy.h header" $ do+    it "finds thcCopyAsyncCPU" $+      runParser' function thcCopyAsyncCPU `shouldBe` Right (Just thcCopyAsyncCPURendered)++    it "finds thcCopyAsyncCuda" $+      runParser' function thcCopyAsyncCuda `shouldBe` Right (Just thcCopyAsyncCudaRendered)++  it "will find functions with comments between arguments, like in THNN.h" $+    runParser' function thNNFunction `shouldBe` Right (Just thNNFunctionRendered)+++thcCopyAsyncCPU  = "THC_API void THCTensor_(copyAsyncCPU)(THCState *state, THCTensor *self, THTensor *src);"+thcCopyAsyncCPURendered = Function (Just (THC, "Tensor")) "copyAsyncCPU"+  [ Arg (Ptr (TenType (Pair (State, THC)))) "state"+  , Arg (Ptr (TenType (Pair (Tensor, THC)))) "self"+  , Arg (Ptr (TenType (Pair (Tensor, TH)))) "src"+  ] (CType CVoid)++thcCopyAsyncCuda = "THC_API void THTensor_(copyAsyncCuda)(THCState *state, THTensor *self, THCTensor *src);"+thcCopyAsyncCudaRendered = Function (Just (TH, "Tensor")) "copyAsyncCuda"+  [ Arg (Ptr (TenType (Pair (State, THC)))) "state"+  , Arg (Ptr (TenType (Pair (Tensor, TH)))) "self"+  , Arg (Ptr (TenType (Pair (Tensor, THC)))) "src"+  ] (CType CVoid)+++-- ========================================================================= --+++exampleGeneric :: String+exampleGeneric = "TH_API void THTensor_(setFlag)(THTensor *self,const char flag);"+exampleGeneric' = Function (Just (TH, "Tensor")) "setFlag" [ Arg (Ptr (TenType (Pair (Tensor, TH)))) "self", Arg (CType CChar) "flag"] (CType CVoid)++withStartJunk :: String -> String+withStartJunk x = "skip this garbage line line\n" <> x++withEndJunk :: String -> String+withEndJunk x = x <> "\nanother garbage line ( )@#R @# 324 32"++withAllJunk :: String -> String+withAllJunk = withEndJunk . withStartJunk++thFileFunction = intercalate ""+  [ "TH_API size_t THFile_readStringRaw(THFile *self, const char *format, char **str_); /* you must "+  , "deallocate str_ */"+  ]++thFileFunctionRendered = Function Nothing "THFile_readStringRaw"+  [ Arg      (Ptr (TenType (Pair (File, TH)))) "self"+  , Arg      (Ptr (CType CChar)) "format"+  , Arg (Ptr (Ptr (CType CChar))) "str_"+  ] (CType CSize)++thLogAddFunction :: String+thLogAddFunction = "TH_API double THLogAdd(double log_a, double log_b);"+thLogAddFunctionRendered = Function Nothing "THLogAdd"+  [ Arg (CType CDouble) "log_a"+  , Arg (CType CDouble) "log_b"+  ] (CType CDouble)++thNNFunction = intercalate "\n"+  [ "TH_API void THNN_(L1Cost_updateOutput)("+  , "         THNNState *state,            // library's state"+  , "         THTensor *input,             // input tensor"+  , "         THTensor *output);           // [OUT] output tensor"+  ]+thNNFunctionRendered = Function (Just (THNN, "")) "L1Cost_updateOutput"+  [ Arg (Ptr (TenType (Pair (State, THNN)))) "state"+  , Arg (Ptr (TenType (Pair (Tensor, TH)))) "input"+  , Arg (Ptr (TenType (Pair (Tensor, TH)))) "output"+  ] (CType CVoid)++++thcRandomFunction = "THC_API void THCRandom_init(struct THCState *state, int num_devices, int current_device);"+thcRandomFunction' = Function Nothing "THCRandom_init" [Arg (Ptr (TenType (Pair (State, THC)))) "state", Arg (CType CInt) "num_devices", Arg (CType CInt) "current_device" ] (CType CVoid)++thFileContents = intercalate ""+  [ "#ifndef TH_FILE_INC\n#define TH_FILE_INC\n\n#include \"THStorage.h\"\n\ntypedef struct THFile__ "+  , "THFile;\n\nTH_API int THFile_isOpened(THFile *self);\nTH_API int THFile_isQuiet(THFile *self);\n"+  , "TH_API int THFile_isReadable(THFile *self);\nTH_API int THFile_isWritable(THFile *self);\nTH_API"+  , "int THFile_isBinary(THFile *self);\nTH_API int THFile_isAutoSpacing(THFile *self);\nTH_API int T"+  , "HFile_hasError(THFile *self);\n\nTH_API void THFile_binary(THFile *self);\nTH_API void THFile_as"+  , "cii(THFile *self);\nTH_API void THFile_autoSpacing(THFile *self);\nTH_API void THFile_noAutoSpac"+  , "ing(THFile *self);\nTH_API void THFile_quiet(THFile *self);\nTH_API void THFile_pedantic(THFile "+  , "*self);\nTH_API void THFile_clearError(THFile *self);\n\n/* scalar */\nTH_API uint8_t THFile_rea"+  , "dByteScalar(THFile *self);\nTH_API int8_t THFile_readCharScalar(THFile *self);\nTH_API int16_t T"+  , "HFile_readShortScalar(THFile *self);\nTH_API int32_t THFile_readIntScalar(THFile *self);\nTH_API"+  , "int64_t THFile_readLongScalar(THFile *self);\nTH_API float THFile_readFloatScalar(THFile *self);"+  , "\nTH_API double THFile_readDoubleScalar(THFile *self);\n\nTH_API void THFile_writeByteScalar(THF"+  , "ile *self, uint8_t scalar);\nTH_API void THFile_writeCharScalar(THFile *self, int8_t scalar);\nT"+  , "H_API void THFile_writeShortScalar(THFile *self, int16_t scalar);\nTH_API void THFile_writeIntSc"+  , "alar(THFile *self, int32_t scalar);\nTH_API void THFile_writeLongScalar(THFile *self, int64_t sc"+  , "alar);\nTH_API void THFile_writeFloatScalar(THFile *self, float scalar);\nTH_API void THFile_wri"+  , "teDoubleScalar(THFile *self, double scalar);\n\n/* storage */\nTH_API size_t THFile_readByte(THF"+  , "ile *self, THByteStorage *storage);\nTH_API size_t THFile_readChar(THFile *self, THCharStorage *"+  , "storage);\nTH_API size_t THFile_readShort(THFile *self, THShortStorage *storage);\nTH_API size_t"+  , "THFile_readInt(THFile *self, THIntStorage *storage);\nTH_API size_t THFile_readLong(THFile *self"+  , ", THLongStorage *storage);\nTH_API size_t THFile_readFloat(THFile *self, THFloatStorage *storage"+  , ");\nTH_API size_t THFile_readDouble(THFile *self, THDoubleStorage *storage);\n\nTH_API size_t TH"+  , "File_writeByte(THFile *self, THByteStorage *storage);\nTH_API size_t THFile_writeChar(THFile *se"+  , "lf, THCharStorage *storage);\nTH_API size_t THFile_writeShort(THFile *self, THShortStorage *stor"+  , "age);\nTH_API size_t THFile_writeInt(THFile *self, THIntStorage *storage);\nTH_API size_t THFile"+  , "_writeLong(THFile *self, THLongStorage *storage);\nTH_API size_t THFile_writeFloat(THFile *self,"+  , "THFloatStorage *storage);\nTH_API size_t THFile_writeDouble(THFile *self, THDoubleStorage *stora"+  , "ge);\n\n/* raw */\nTH_API size_t THFile_readByteRaw(THFile *self, uint8_t *data, size_t n);\nTH_"+  , "API size_t THFile_readCharRaw(THFile *self, int8_t *data, size_t n);\nTH_API size_t THFile_readS"+  , "hortRaw(THFile *self, int16_t *data, size_t n);\nTH_API size_t THFile_readIntRaw(THFile *self, i"+  , "nt32_t *data, size_t n);\nTH_API size_t THFile_readLongRaw(THFile *self, int64_t *data, size_t n"+  , ");\nTH_API size_t THFile_readFloatRaw(THFile *self, float *data, size_t n);\nTH_API size_t THFil"+  , "e_readDoubleRaw(THFile *self, double *data, size_t n);\nTH_API size_t THFile_readStringRaw(THFil"+  , "e *self, const char *format, char **str_); /* you must deallocate str_ */\n\nTH_API size_t THFil"+  , "e_writeByteRaw(THFile *self, uint8_t *data, size_t n);\nTH_API size_t THFile_writeCharRaw(THFile"+  , "*self, int8_t *data, size_t n);\nTH_API size_t THFile_writeShortRaw(THFile *self, int16_t *data,"+  , "size_t n);\nTH_API size_t THFile_writeIntRaw(THFile *self, int32_t *data, size_t n);\nTH_API siz"+  , "e_t THFile_writeLongRaw(THFile *self, int64_t *data, size_t n);\nTH_API size_t THFile_writeFloat"+  , "Raw(THFile *self, float *data, size_t n);\nTH_API size_t THFile_writeDoubleRaw(THFile *self, dou"+  , "ble *data, size_t n);\nTH_API size_t THFile_writeStringRaw(THFile *self, const char *str, size_t"+  , "size);\n\nTH_API THHalf THFile_readHalfScalar(THFile *self);\nTH_API void THFile_writeHalfScalar"+  , "(THFile *self, THHalf scalar);\nTH_API size_t THFile_readHalf(THFile *self, THHalfStorage *stora"+  , "ge);\nTH_API size_t THFile_writeHalf(THFile *self, THHalfStorage *storage);\nTH_API size_t THFil"+  , "e_readHalfRaw(THFile *self, THHalf* data, size_t size);\nTH_API size_t THFile_writeHalfRaw(THFil"+  , "e *self, THHalf* data, size_t size);\n\nTH_API void THFile_synchronize(THFile *self);\nTH_API vo"+  , "id THFile_seek(THFile *self, size_t position);\nTH_API void THFile_seekEnd(THFile *self);\nTH_AP"+  , "I size_t THFile_position(THFile *self);\nTH_API void THFile_close(THFile *self);\nTH_API void TH"+  , "File_free(THFile *self);\n\n#endif\n"+  ]++storageElementSize :: String+storageElementSize = "TH_API size_t THStorage_(elementSize)(void);"++storageElementSize' :: Function+storageElementSize' = Function (Just (TH, "Storage")) "elementSize" [ Arg (CType CVoid) "" ] (CType CSize)++thGenericStorageContents :: String+thGenericStorageContents = intercalate ""+  [ "#ifndef TH_GENERIC_FILE\n#define TH_GENERIC_FILE \"generic/THStorage.h\"\n#else\n\n/* on pourra"+  , "it avoir un liste chainee\n   qui initialise math, lab structures (or more).\n   mouais -- comp"+  , "lique.\n\n   Pb: THMapStorage is kind of a class\n   THLab_()... comment je m'en sors?\n\n   en"+  , " template, faudrait que je les instancie toutes!!! oh boy!\n   Et comment je sais que c'est pou"+  , "r Cuda? Le type float est le meme dans les <>\n\n   au bout du compte, ca serait sur des pointe"+  , "urs float/double... etc... = facile.\n   primitives??\n */\n\n#define TH_STORAGE_REFCOUNTED 1\n"+  , "#define TH_STORAGE_RESIZABLE  2\n#define TH_STORAGE_FREEMEM    4\n#define TH_STORAGE_VIEW      "+  , " 8\n\ntypedef struct THStorage\n{\n    real *data;\n    ptrdiff_t size;\n    int refcount;\n   "+  , " char flag;\n    THAllocator *allocator;\n    void *allocatorContext;\n    struct THStorage *vi"+  , "ew;\n} THStorage;\n\nTH_API real* THStorage_(data)(const THStorage*);\nTH_API ptrdiff_t THStora"+  , "ge_(size)(const THStorage*);\nTH_API size_t THStorage_(elementSize)(void);\n\n/* slow access --"+  , " checks everything */\nTH_API void THStorage_(set)(THStorage*, ptrdiff_t, real);\nTH_API real T"+  , "HStorage_(get)(const THStorage*, ptrdiff_t);\n\nTH_API THStorage* THStorage_(new)(void);\nTH_AP"+  , "I THStorage* THStorage_(newWithSize)(ptrdiff_t size);\nTH_API THStorage* THStorage_(newWithSize"+  , "1)(real);\nTH_API THStorage* THStorage_(newWithSize2)(real, real);\nTH_API THStorage* THStorage"+  , "_(newWithSize3)(real, real, real);\nTH_API THStorage* THStorage_(newWithSize4)(real, real, real"+  , ", real);\nTH_API THStorage* THStorage_(newWithMapping)(const char *filename, ptrdiff_t size, in"+  , "t flags);\n\n/* takes ownership of data */\nTH_API THStorage* THStorage_(newWithData)(real *dat"+  , "a, ptrdiff_t size);\n\nTH_API THStorage* THStorage_(newWithAllocator)(ptrdiff_t size,\n        "+  , "                                       THAllocator* allocator,\n                               "+  , "                void *allocatorContext);\nTH_API THStorage* THStorage_(newWithDataAndAllocator)"+  , "(\n    real* data, ptrdiff_t size, THAllocator* allocator, void *allocatorContext);\n\n/* shoul"+  , "d not differ with API */\nTH_API void THStorage_(setFlag)(THStorage *storage, const char flag);"+  , "\nTH_API void THStorage_(clearFlag)(THStorage *storage, const char flag);\nTH_API void THStorag"+  , "e_(retain)(THStorage *storage);\nTH_API void THStorage_(swap)(THStorage *storage1, THStorage *s"+  , "torage2);\n\n/* might differ with other API (like CUDA) */\nTH_API void THStorage_(free)(THStor"+  , "age *storage);\nTH_API void THStorage_(resize)(THStorage *storage, ptrdiff_t size);\nTH_API voi"+  , "d THStorage_(fill)(THStorage *storage, real value);\n\n#endif\n"+  ]++thcGenericTensorTopKContents :: String+thcGenericTensorTopKContents = intercalate ""+  [ "#ifndef THC_GENERIC_FILE\n#define THC_GENERIC_FILE \"generic/THCTensorTopK.h\"\n#else\n\n/* Ret"+  , "urns the set of all kth smallest (or largest) elements, depending */\n/* on `dir` */\nTHC_API v"+  , "oid THCTensor_(topk)(THCState* state,\n                               THCTensor* topK,\n       "+  , "                        THCudaLongTensor* indices,\n                               THCTensor* i"+  , "nput,\n                               int64_t k, int dim, int dir, int sorted);\n\n#endif // TH"+  , "C_GENERIC_FILE\n"+  ]++thcGenericTensorTopKFunction :: String+thcGenericTensorTopKFunction = intercalate ""+  [ "THC_API void THCTensor_(topk)(THCState* state,\n"+  , "                               THCTensor* topK,"+  , "\n                               THCudaLongTens"+  , "or* indices,\n                               THC"+  , "Tensor* input,\n                               "+  , "int64_t k, int dim, int dir, int sorted);"+  ]++thcGenericTensorTopKFunction' :: Function+thcGenericTensorTopKFunction'+  = Function (Just (THC, "Tensor")) "topk"+  [ Arg (Ptr (TenType (Pair (State, THC)))) "state"+  , Arg (Ptr (TenType (Pair (Tensor, THC)))) "topK"+  , Arg (Ptr (TenType (Pair (LongTensor, THCUNN)))) "indices"+  , Arg (Ptr (TenType (Pair (Tensor, THC)))) "input"+  , Arg (CType CInt64) "k"+  , Arg (CType CInt) "dim"+  , Arg (CType CInt) "dir"+  , Arg (CType CInt) "sorted"+  ] (CType CVoid)
+ tests/CodeGen/Render/CSpec.hs view
@@ -0,0 +1,50 @@+module CodeGen.Render.CSpec where++import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import CodeGen.Render.C+import CodeGen.Prelude+import CodeGen.Types+import CodeGen.Instances++main :: IO ()+main = hspec spec++spec :: Spec+spec =+  describe "renderTenType" renderTenTypeSpec++renderTenTypeSpec :: Spec+renderTenTypeSpec = do+  prop "renders accreal and real the same regardless of Libtype" $ \(lt1, lt2) -> do+    renderTenType (Pair (Real, lt1)) `shouldBe` renderTenType (Pair (Real, lt2))+    renderTenType (Pair (AccReal, lt1)) `shouldBe` renderTenType (Pair (AccReal, lt2))++  it "renders all non-THC prefixes as the library appended to the raw tensor type"+    . propertyST (\p -> not . or . fmap ($ p) $ [isTHC, isReal, isTHCUNN]) $+    \tt@(Pair (raw, l)) ->+      renderTenType tt `shouldBe` (tshow l <> tshow raw)++  it "renders THC as THCuda for concrete tensor types"+    . propertyST (\p -> isTHC p && not (isReal p)) $+    \tt@(Pair (raw, _)) ->+      -- (if isConcreteCudaPrefixed p then "THCuda" else tshow lib)+      if isConcreteCudaPrefixed tt+      then renderTenType tt `shouldBe` ("THCuda" <> tshow raw)+      else renderTenType tt `shouldBe` ("THC" <> tshow raw)++ where+  propertyST+    :: Arbitrary a+    => Show a+    => Testable prop+    => (a -> Bool)+    -> (a -> prop)+    -> Property+  propertyST cond = forAll (suchThat arbitrary cond)++  isTHC (Pair(_, l)) = l == THC+  isTHCUNN (Pair(_, l)) = l == THCUNN+  isReal (Pair(r, _)) = r == AccReal || r == Real+
+ tests/CodeGen/Render/FunctionSpec.hs view
@@ -0,0 +1,47 @@+module CodeGen.Render.FunctionSpec where++import Test.Hspec+import CodeGen.Render.Function+import CodeGen.Types hiding (describe)+import CodeGen.Prelude+++main :: IO ()+main = hspec spec+++spec :: Spec+spec = do+  describe "rendering the debugging function `sizeDesc`" $+    describe "returning `Ptr C'THDescBuff` instead of CTHDescBuff for generic/THCTensor.h#sizeDesc" $ do++    let sizeDescSig = "sizeDesc :: Ptr C'THCState -> Ptr C'THCudaFloatTensor -> IO (Ptr C'THCDescBuff)"+    it "works as expected in haskellSig" $ do+      haskellSig THC "sizeDesc" IsFun GenFloat+        [ Arg (Ptr (TenType (Pair (State, THC)))) "state"+        , Arg (Ptr (TenType (Pair (Tensor, THC)))) "tensor"+        ] (TenType (Pair (DescBuff, THC)))+        `shouldBe` sizeDescSig++    it "works as expected in renderSig" $ do+      renderSig IsFun THC GenericFiles "test" GenFloat "Tensor" "Tensor"+        (Nothing, "sizeDesc", TenType (Pair (DescBuff, THC)),+          [ Arg (Ptr (TenType (Pair (State,  THC)))) "state"+          , Arg (Ptr (TenType (Pair (Tensor, THC)))) "tensor"])+        `shouldBe` ("-- | c_sizeDesc :  state tensor -> THCDescBuff\n"+          <> "foreign import ccall \"test THCudaFloatTensor_sizeDesc\""+          <> "\n  c_" <> sizeDescSig)++  let copyAsyncCudaSig =+        "thCopyAsyncCuda :: Ptr C'THCState -> Ptr C'THFloatTensor -> Ptr C'THCudaFloatTensor -> IO ()"++  it "renders functions with the correct C symbol when passed a prefix" $ do+    renderSig IsFun THC GenericFiles "test" GenFloat "Tensor" "Tensor"+      (Just (TH, "Tensor"), "copyAsyncCuda", CType CVoid,+        [ Arg (Ptr (TenType (Pair (State,  THC)))) "state"+        , Arg (Ptr (TenType (Pair (Tensor, TH)))) "self"+        , Arg (Ptr (TenType (Pair (Tensor, THC)))) "src"])+      `shouldBe` ("-- | c_thCopyAsyncCuda :  state self src -> void\n"+        <> "foreign import ccall \"test THFloatTensor_copyAsyncCuda\""+        <> "\n  c_" <> copyAsyncCudaSig)+
+ tests/CodeGen/RenderSpec.hs view
@@ -0,0 +1,22 @@+module CodeGen.RenderSpec where++import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck hiding (Function)+import CodeGen.Render+import CodeGen.Prelude+import CodeGen.Types+import CodeGen.Instances++main :: IO ()+main = hspec spec++spec :: Spec+spec =+  xdescribe "renderFunctions" renderFunctionsSpec++renderFunctionsSpec :: Spec+renderFunctionsSpec = do+  it "renders functions with their prefix if there is a name collision" $ do+    pendingWith "not sure this should be tested here. It looks like it will be placed in a helper function"+
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}