diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -8,11 +8,15 @@ import System.FilePath import GHC.Paths import Data.Version +import System.Info showBootVersion :: Version -> LocalBuildInfo -> String showBootVersion ver lbi = - "haste-" ++ showVersion ver ++ "_ghc-" ++ ghcver + arch ++ "-" ++ myos ++ "-haste-" ++ showVersion ver ++ "-ghc-" ++ ghcver where + myos + | os == "mingw32" = "windows" + | otherwise = os ghcver = case compilerId $ compiler lbi of CompilerId GHC ver -> showVersion ver @@ -26,10 +30,12 @@ | exe <- executables pkgdesc] builddir = buildDir buildinfo outdir = dirname + versubdir = showBootVersion (pkgVersion $ package pkgdesc) buildinfo + jsdir = outdir versubdir "js" datadir = dataDir $ localPkgDescr buildinfo jsfiles = dataFiles $ localPkgDescr buildinfo hastedirfile = ".hastedir" -- does Haste "own" this directory? - + dirExists <- doesDirectoryExist outdir isHasteDir <- doesFileExist (outdir hastedirfile) when (dirExists && not isHasteDir) $ @@ -40,13 +46,10 @@ removeDirectoryRecursive outdir -- Create directory and mark as ours - createDirectoryIfMissing True (outdir "js") + createDirectoryIfMissing True jsdir createDirectoryIfMissing True (outdir "bin") writeFile (outdir ".hastedir") "" - -- Copy settings and tools. - copyGhcSettings outdir - -- Copy executables forM_ exes $ \exe -> do exists <- doesFileExist $ builddir exe exe @@ -58,33 +61,13 @@ -- Copy libs forM_ jsfiles $ \js -> do - copyFile (datadir js) (outdir "js" js) - -cabalPostBuild :: PackageDescription -> LocalBuildInfo -> IO () -cabalPostBuild pkgdesc lbi = do - appdir <- getAppUserDataDirectory "haste" - let dest = appdir showBootVersion (pkgVersion $ package pkgdesc) lbi - createDirectoryIfMissing True dest - copyGhcSettings dest - --- | Copy GHC settings and utils into the given directory. -copyGhcSettings :: FilePath -> IO () -copyGhcSettings dest = do - copyFile (libdir "platformConstants") (dest "platformConstants") -#ifdef mingw32_HOST_OS - copyFile ("settings.windows") (dest "settings") - copyFile (libdir "unlit.exe") (dest "unlit.exe") - copyFile (libdir "touchy.exe") (dest "touchy.exe") -#else - copyFile (libdir "settings") (dest "settings") - copyFile (libdir "unlit") (dest "unlit") -#endif + copyFile (datadir js) (jsdir js) main = defaultMainWithHooks $ simpleUserHooks { postBuild = \_ _ pkgdesc buildinfo -> do if (buildinfo `has` "portable" || buildinfo `has` "portable-compiler") then portablePostBuild pkgdesc buildinfo - else cabalPostBuild pkgdesc buildinfo + else return () } has :: LocalBuildInfo -> String -> Bool diff --git a/haste-compiler.cabal b/haste-compiler.cabal --- a/haste-compiler.cabal +++ b/haste-compiler.cabal @@ -1,5 +1,5 @@ Name: haste-compiler -Version: 0.5.0.1 +Version: 0.5.1.0 License: BSD3 License-File: LICENSE Synopsis: Haskell To ECMAScript compiler @@ -8,6 +8,10 @@ use of standard Haskell libraries, integrates with Cabal, supports most GHC extensions and works on Windows, Linux and OSX. + + Non-Linux users are strongly recommended to download pre-built + binary packages from http://haste-lang.org/downloads instead + of building from source. Category: JavaScript, Compiler, Web Cabal-Version: >= 1.10 Build-Type: Custom @@ -42,6 +46,10 @@ jsstring.js Foreign.js +extra-source-files: + include/primop-info-710.hs, + include/primop-stricts-710.hs + Flag portable Description: Install Haste into a self-contained directory. Package databases are @@ -89,13 +97,15 @@ shellmate >= 0.1.5, ghc-paths, ghc, - directory + directory, + filepath Default-Language: Haskell98 Executable hastec if flag(only-library) buildable: False Hs-Source-Dirs: src + Include-Dirs: include GHC-Options: -Wall -O2 if flag(portable) CPP-Options: -DPORTABLE @@ -108,7 +118,7 @@ Build-Depends: base < 5, ghc-prim, - ghc >= 7.8 && < 7.10, + ghc >= 7.8 && < 7.11, mtl, binary, containers, @@ -121,6 +131,7 @@ system-fileio, shellmate >= 0.1.5, either, + filepath, directory, ghc-simple >= 0.1.2.1 Main-Is: @@ -140,6 +151,7 @@ Haste.Builtins Haste.Errors Haste.CodeGen + Haste.JSLib Data.JSTarget Data.JSTarget.AST Data.JSTarget.Binary @@ -151,32 +163,13 @@ Data.JSTarget.Traversal default-language: Haskell98 -Executable haste-cabal - if flag(only-library) - buildable: False - Main-Is: haste-cabal.hs - Hs-Source-Dirs: src - if flag(portable) - CPP-Options: -DPORTABLE - if flag(static) - if os(windows) - GHC-Options: -static -optl-static - else - if os(linux) - GHC-Options: -static -optl-static -optl-pthread - Build-Depends: - base < 5, - shellmate, - ghc-paths, - ghc, - directory - default-language: Haskell98 - Executable haste-pkg Default-Language: Haskell2010 Main-Is: haste-pkg.hs - Other-Modules: Other-Extensions: CPP + Other-Modules: + HastePkg710 + HastePkg708 Hs-Source-Dirs: src utils/haste-pkg @@ -278,7 +271,7 @@ default-language: Haskell98 Library - Hs-Source-Dirs: libraries/haste-lib/src, src + Hs-Source-Dirs: libraries/haste-lib/src, libraries/haste-prim/src, src GHC-Options: -Wall -O2 Exposed-Modules: Haste @@ -305,7 +298,6 @@ Haste.Serialize Haste.WebSockets Other-Modules: - Haste.Any Haste.App.Client Haste.App.Monad Haste.App.Protocol @@ -324,7 +316,9 @@ Haste.Events.MouseEvents Haste.GHCPaths Haste.Hash - Haste.JSType + Haste.Prim.Any + Haste.Prim.Foreign + Haste.Prim.JSType Haste.Random Haste.Timer Haste.Version diff --git a/include/primop-info-710.hs b/include/primop-info-710.hs new file mode 100644 --- /dev/null +++ b/include/primop-info-710.hs @@ -0,0 +1,1062 @@ +primOpInfo CharGtOp = mkCompare (fsLit "gtChar#") charPrimTy +primOpInfo CharGeOp = mkCompare (fsLit "geChar#") charPrimTy +primOpInfo CharEqOp = mkCompare (fsLit "eqChar#") charPrimTy +primOpInfo CharNeOp = mkCompare (fsLit "neChar#") charPrimTy +primOpInfo CharLtOp = mkCompare (fsLit "ltChar#") charPrimTy +primOpInfo CharLeOp = mkCompare (fsLit "leChar#") charPrimTy +primOpInfo OrdOp = mkGenPrimOp (fsLit "ord#") [] [charPrimTy] (intPrimTy) +primOpInfo IntAddOp = mkDyadic (fsLit "+#") intPrimTy +primOpInfo IntSubOp = mkDyadic (fsLit "-#") intPrimTy +primOpInfo IntMulOp = mkDyadic (fsLit "*#") intPrimTy +primOpInfo IntMulMayOfloOp = mkDyadic (fsLit "mulIntMayOflo#") intPrimTy +primOpInfo IntQuotOp = mkDyadic (fsLit "quotInt#") intPrimTy +primOpInfo IntRemOp = mkDyadic (fsLit "remInt#") intPrimTy +primOpInfo IntQuotRemOp = mkGenPrimOp (fsLit "quotRemInt#") [] [intPrimTy, intPrimTy] ((mkTupleTy UnboxedTuple [intPrimTy, intPrimTy])) +primOpInfo AndIOp = mkDyadic (fsLit "andI#") intPrimTy +primOpInfo OrIOp = mkDyadic (fsLit "orI#") intPrimTy +primOpInfo XorIOp = mkDyadic (fsLit "xorI#") intPrimTy +primOpInfo NotIOp = mkMonadic (fsLit "notI#") intPrimTy +primOpInfo IntNegOp = mkMonadic (fsLit "negateInt#") intPrimTy +primOpInfo IntAddCOp = mkGenPrimOp (fsLit "addIntC#") [] [intPrimTy, intPrimTy] ((mkTupleTy UnboxedTuple [intPrimTy, intPrimTy])) +primOpInfo IntSubCOp = mkGenPrimOp (fsLit "subIntC#") [] [intPrimTy, intPrimTy] ((mkTupleTy UnboxedTuple [intPrimTy, intPrimTy])) +primOpInfo IntGtOp = mkCompare (fsLit ">#") intPrimTy +primOpInfo IntGeOp = mkCompare (fsLit ">=#") intPrimTy +primOpInfo IntEqOp = mkCompare (fsLit "==#") intPrimTy +primOpInfo IntNeOp = mkCompare (fsLit "/=#") intPrimTy +primOpInfo IntLtOp = mkCompare (fsLit "<#") intPrimTy +primOpInfo IntLeOp = mkCompare (fsLit "<=#") intPrimTy +primOpInfo ChrOp = mkGenPrimOp (fsLit "chr#") [] [intPrimTy] (charPrimTy) +primOpInfo Int2WordOp = mkGenPrimOp (fsLit "int2Word#") [] [intPrimTy] (wordPrimTy) +primOpInfo Int2FloatOp = mkGenPrimOp (fsLit "int2Float#") [] [intPrimTy] (floatPrimTy) +primOpInfo Int2DoubleOp = mkGenPrimOp (fsLit "int2Double#") [] [intPrimTy] (doublePrimTy) +primOpInfo Word2FloatOp = mkGenPrimOp (fsLit "word2Float#") [] [wordPrimTy] (floatPrimTy) +primOpInfo Word2DoubleOp = mkGenPrimOp (fsLit "word2Double#") [] [wordPrimTy] (doublePrimTy) +primOpInfo ISllOp = mkGenPrimOp (fsLit "uncheckedIShiftL#") [] [intPrimTy, intPrimTy] (intPrimTy) +primOpInfo ISraOp = mkGenPrimOp (fsLit "uncheckedIShiftRA#") [] [intPrimTy, intPrimTy] (intPrimTy) +primOpInfo ISrlOp = mkGenPrimOp (fsLit "uncheckedIShiftRL#") [] [intPrimTy, intPrimTy] (intPrimTy) +primOpInfo WordAddOp = mkDyadic (fsLit "plusWord#") wordPrimTy +primOpInfo WordAdd2Op = mkGenPrimOp (fsLit "plusWord2#") [] [wordPrimTy, wordPrimTy] ((mkTupleTy UnboxedTuple [wordPrimTy, wordPrimTy])) +primOpInfo WordSubOp = mkDyadic (fsLit "minusWord#") wordPrimTy +primOpInfo WordMulOp = mkDyadic (fsLit "timesWord#") wordPrimTy +primOpInfo WordMul2Op = mkGenPrimOp (fsLit "timesWord2#") [] [wordPrimTy, wordPrimTy] ((mkTupleTy UnboxedTuple [wordPrimTy, wordPrimTy])) +primOpInfo WordQuotOp = mkDyadic (fsLit "quotWord#") wordPrimTy +primOpInfo WordRemOp = mkDyadic (fsLit "remWord#") wordPrimTy +primOpInfo WordQuotRemOp = mkGenPrimOp (fsLit "quotRemWord#") [] [wordPrimTy, wordPrimTy] ((mkTupleTy UnboxedTuple [wordPrimTy, wordPrimTy])) +primOpInfo WordQuotRem2Op = mkGenPrimOp (fsLit "quotRemWord2#") [] [wordPrimTy, wordPrimTy, wordPrimTy] ((mkTupleTy UnboxedTuple [wordPrimTy, wordPrimTy])) +primOpInfo AndOp = mkDyadic (fsLit "and#") wordPrimTy +primOpInfo OrOp = mkDyadic (fsLit "or#") wordPrimTy +primOpInfo XorOp = mkDyadic (fsLit "xor#") wordPrimTy +primOpInfo NotOp = mkMonadic (fsLit "not#") wordPrimTy +primOpInfo SllOp = mkGenPrimOp (fsLit "uncheckedShiftL#") [] [wordPrimTy, intPrimTy] (wordPrimTy) +primOpInfo SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRL#") [] [wordPrimTy, intPrimTy] (wordPrimTy) +primOpInfo Word2IntOp = mkGenPrimOp (fsLit "word2Int#") [] [wordPrimTy] (intPrimTy) +primOpInfo WordGtOp = mkCompare (fsLit "gtWord#") wordPrimTy +primOpInfo WordGeOp = mkCompare (fsLit "geWord#") wordPrimTy +primOpInfo WordEqOp = mkCompare (fsLit "eqWord#") wordPrimTy +primOpInfo WordNeOp = mkCompare (fsLit "neWord#") wordPrimTy +primOpInfo WordLtOp = mkCompare (fsLit "ltWord#") wordPrimTy +primOpInfo WordLeOp = mkCompare (fsLit "leWord#") wordPrimTy +primOpInfo PopCnt8Op = mkMonadic (fsLit "popCnt8#") wordPrimTy +primOpInfo PopCnt16Op = mkMonadic (fsLit "popCnt16#") wordPrimTy +primOpInfo PopCnt32Op = mkMonadic (fsLit "popCnt32#") wordPrimTy +primOpInfo PopCnt64Op = mkGenPrimOp (fsLit "popCnt64#") [] [word64PrimTy] (wordPrimTy) +primOpInfo PopCntOp = mkMonadic (fsLit "popCnt#") wordPrimTy +primOpInfo Clz8Op = mkMonadic (fsLit "clz8#") wordPrimTy +primOpInfo Clz16Op = mkMonadic (fsLit "clz16#") wordPrimTy +primOpInfo Clz32Op = mkMonadic (fsLit "clz32#") wordPrimTy +primOpInfo Clz64Op = mkGenPrimOp (fsLit "clz64#") [] [word64PrimTy] (wordPrimTy) +primOpInfo ClzOp = mkMonadic (fsLit "clz#") wordPrimTy +primOpInfo Ctz8Op = mkMonadic (fsLit "ctz8#") wordPrimTy +primOpInfo Ctz16Op = mkMonadic (fsLit "ctz16#") wordPrimTy +primOpInfo Ctz32Op = mkMonadic (fsLit "ctz32#") wordPrimTy +primOpInfo Ctz64Op = mkGenPrimOp (fsLit "ctz64#") [] [word64PrimTy] (wordPrimTy) +primOpInfo CtzOp = mkMonadic (fsLit "ctz#") wordPrimTy +primOpInfo BSwap16Op = mkMonadic (fsLit "byteSwap16#") wordPrimTy +primOpInfo BSwap32Op = mkMonadic (fsLit "byteSwap32#") wordPrimTy +primOpInfo BSwap64Op = mkMonadic (fsLit "byteSwap64#") word64PrimTy +primOpInfo BSwapOp = mkMonadic (fsLit "byteSwap#") wordPrimTy +primOpInfo Narrow8IntOp = mkMonadic (fsLit "narrow8Int#") intPrimTy +primOpInfo Narrow16IntOp = mkMonadic (fsLit "narrow16Int#") intPrimTy +primOpInfo Narrow32IntOp = mkMonadic (fsLit "narrow32Int#") intPrimTy +primOpInfo Narrow8WordOp = mkMonadic (fsLit "narrow8Word#") wordPrimTy +primOpInfo Narrow16WordOp = mkMonadic (fsLit "narrow16Word#") wordPrimTy +primOpInfo Narrow32WordOp = mkMonadic (fsLit "narrow32Word#") wordPrimTy +primOpInfo DoubleGtOp = mkCompare (fsLit ">##") doublePrimTy +primOpInfo DoubleGeOp = mkCompare (fsLit ">=##") doublePrimTy +primOpInfo DoubleEqOp = mkCompare (fsLit "==##") doublePrimTy +primOpInfo DoubleNeOp = mkCompare (fsLit "/=##") doublePrimTy +primOpInfo DoubleLtOp = mkCompare (fsLit "<##") doublePrimTy +primOpInfo DoubleLeOp = mkCompare (fsLit "<=##") doublePrimTy +primOpInfo DoubleAddOp = mkDyadic (fsLit "+##") doublePrimTy +primOpInfo DoubleSubOp = mkDyadic (fsLit "-##") doublePrimTy +primOpInfo DoubleMulOp = mkDyadic (fsLit "*##") doublePrimTy +primOpInfo DoubleDivOp = mkDyadic (fsLit "/##") doublePrimTy +primOpInfo DoubleNegOp = mkMonadic (fsLit "negateDouble#") doublePrimTy +primOpInfo Double2IntOp = mkGenPrimOp (fsLit "double2Int#") [] [doublePrimTy] (intPrimTy) +primOpInfo Double2FloatOp = mkGenPrimOp (fsLit "double2Float#") [] [doublePrimTy] (floatPrimTy) +primOpInfo DoubleExpOp = mkMonadic (fsLit "expDouble#") doublePrimTy +primOpInfo DoubleLogOp = mkMonadic (fsLit "logDouble#") doublePrimTy +primOpInfo DoubleSqrtOp = mkMonadic (fsLit "sqrtDouble#") doublePrimTy +primOpInfo DoubleSinOp = mkMonadic (fsLit "sinDouble#") doublePrimTy +primOpInfo DoubleCosOp = mkMonadic (fsLit "cosDouble#") doublePrimTy +primOpInfo DoubleTanOp = mkMonadic (fsLit "tanDouble#") doublePrimTy +primOpInfo DoubleAsinOp = mkMonadic (fsLit "asinDouble#") doublePrimTy +primOpInfo DoubleAcosOp = mkMonadic (fsLit "acosDouble#") doublePrimTy +primOpInfo DoubleAtanOp = mkMonadic (fsLit "atanDouble#") doublePrimTy +primOpInfo DoubleSinhOp = mkMonadic (fsLit "sinhDouble#") doublePrimTy +primOpInfo DoubleCoshOp = mkMonadic (fsLit "coshDouble#") doublePrimTy +primOpInfo DoubleTanhOp = mkMonadic (fsLit "tanhDouble#") doublePrimTy +primOpInfo DoublePowerOp = mkDyadic (fsLit "**##") doublePrimTy +primOpInfo DoubleDecode_2IntOp = mkGenPrimOp (fsLit "decodeDouble_2Int#") [] [doublePrimTy] ((mkTupleTy UnboxedTuple [intPrimTy, wordPrimTy, wordPrimTy, intPrimTy])) +primOpInfo DoubleDecode_Int64Op = mkGenPrimOp (fsLit "decodeDouble_Int64#") [] [doublePrimTy] ((mkTupleTy UnboxedTuple [int64PrimTy, intPrimTy])) +primOpInfo FloatGtOp = mkCompare (fsLit "gtFloat#") floatPrimTy +primOpInfo FloatGeOp = mkCompare (fsLit "geFloat#") floatPrimTy +primOpInfo FloatEqOp = mkCompare (fsLit "eqFloat#") floatPrimTy +primOpInfo FloatNeOp = mkCompare (fsLit "neFloat#") floatPrimTy +primOpInfo FloatLtOp = mkCompare (fsLit "ltFloat#") floatPrimTy +primOpInfo FloatLeOp = mkCompare (fsLit "leFloat#") floatPrimTy +primOpInfo FloatAddOp = mkDyadic (fsLit "plusFloat#") floatPrimTy +primOpInfo FloatSubOp = mkDyadic (fsLit "minusFloat#") floatPrimTy +primOpInfo FloatMulOp = mkDyadic (fsLit "timesFloat#") floatPrimTy +primOpInfo FloatDivOp = mkDyadic (fsLit "divideFloat#") floatPrimTy +primOpInfo FloatNegOp = mkMonadic (fsLit "negateFloat#") floatPrimTy +primOpInfo Float2IntOp = mkGenPrimOp (fsLit "float2Int#") [] [floatPrimTy] (intPrimTy) +primOpInfo FloatExpOp = mkMonadic (fsLit "expFloat#") floatPrimTy +primOpInfo FloatLogOp = mkMonadic (fsLit "logFloat#") floatPrimTy +primOpInfo FloatSqrtOp = mkMonadic (fsLit "sqrtFloat#") floatPrimTy +primOpInfo FloatSinOp = mkMonadic (fsLit "sinFloat#") floatPrimTy +primOpInfo FloatCosOp = mkMonadic (fsLit "cosFloat#") floatPrimTy +primOpInfo FloatTanOp = mkMonadic (fsLit "tanFloat#") floatPrimTy +primOpInfo FloatAsinOp = mkMonadic (fsLit "asinFloat#") floatPrimTy +primOpInfo FloatAcosOp = mkMonadic (fsLit "acosFloat#") floatPrimTy +primOpInfo FloatAtanOp = mkMonadic (fsLit "atanFloat#") floatPrimTy +primOpInfo FloatSinhOp = mkMonadic (fsLit "sinhFloat#") floatPrimTy +primOpInfo FloatCoshOp = mkMonadic (fsLit "coshFloat#") floatPrimTy +primOpInfo FloatTanhOp = mkMonadic (fsLit "tanhFloat#") floatPrimTy +primOpInfo FloatPowerOp = mkDyadic (fsLit "powerFloat#") floatPrimTy +primOpInfo Float2DoubleOp = mkGenPrimOp (fsLit "float2Double#") [] [floatPrimTy] (doublePrimTy) +primOpInfo FloatDecode_IntOp = mkGenPrimOp (fsLit "decodeFloat_Int#") [] [floatPrimTy] ((mkTupleTy UnboxedTuple [intPrimTy, intPrimTy])) +primOpInfo NewArrayOp = mkGenPrimOp (fsLit "newArray#") [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) +primOpInfo SameMutableArrayOp = mkGenPrimOp (fsLit "sameMutableArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy) +primOpInfo ReadArrayOp = mkGenPrimOp (fsLit "readArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, alphaTy])) +primOpInfo WriteArrayOp = mkGenPrimOp (fsLit "writeArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo SizeofArrayOp = mkGenPrimOp (fsLit "sizeofArray#") [alphaTyVar] [mkArrayPrimTy alphaTy] (intPrimTy) +primOpInfo SizeofMutableArrayOp = mkGenPrimOp (fsLit "sizeofMutableArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy) +primOpInfo IndexArrayOp = mkGenPrimOp (fsLit "indexArray#") [alphaTyVar] [mkArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy UnboxedTuple [alphaTy])) +primOpInfo UnsafeFreezeArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy])) +primOpInfo UnsafeThawArrayOp = mkGenPrimOp (fsLit "unsafeThawArray#") [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) +primOpInfo CopyArrayOp = mkGenPrimOp (fsLit "copyArray#") [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CopyMutableArrayOp = mkGenPrimOp (fsLit "copyMutableArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CloneArrayOp = mkGenPrimOp (fsLit "cloneArray#") [alphaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkArrayPrimTy alphaTy) +primOpInfo CloneMutableArrayOp = mkGenPrimOp (fsLit "cloneMutableArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) +primOpInfo FreezeArrayOp = mkGenPrimOp (fsLit "freezeArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy])) +primOpInfo ThawArrayOp = mkGenPrimOp (fsLit "thawArray#") [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) +primOpInfo CasArrayOp = mkGenPrimOp (fsLit "casArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) +primOpInfo NewSmallArrayOp = mkGenPrimOp (fsLit "newSmallArray#") [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) +primOpInfo SameSmallMutableArrayOp = mkGenPrimOp (fsLit "sameSmallMutableArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy) +primOpInfo ReadSmallArrayOp = mkGenPrimOp (fsLit "readSmallArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, alphaTy])) +primOpInfo WriteSmallArrayOp = mkGenPrimOp (fsLit "writeSmallArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo SizeofSmallArrayOp = mkGenPrimOp (fsLit "sizeofSmallArray#") [alphaTyVar] [mkSmallArrayPrimTy alphaTy] (intPrimTy) +primOpInfo SizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "sizeofSmallMutableArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy) +primOpInfo IndexSmallArrayOp = mkGenPrimOp (fsLit "indexSmallArray#") [alphaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy UnboxedTuple [alphaTy])) +primOpInfo UnsafeFreezeSmallArrayOp = mkGenPrimOp (fsLit "unsafeFreezeSmallArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy])) +primOpInfo UnsafeThawSmallArrayOp = mkGenPrimOp (fsLit "unsafeThawSmallArray#") [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) +primOpInfo CopySmallArrayOp = mkGenPrimOp (fsLit "copySmallArray#") [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CopySmallMutableArrayOp = mkGenPrimOp (fsLit "copySmallMutableArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CloneSmallArrayOp = mkGenPrimOp (fsLit "cloneSmallArray#") [alphaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkSmallArrayPrimTy alphaTy) +primOpInfo CloneSmallMutableArrayOp = mkGenPrimOp (fsLit "cloneSmallMutableArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) +primOpInfo FreezeSmallArrayOp = mkGenPrimOp (fsLit "freezeSmallArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy])) +primOpInfo ThawSmallArrayOp = mkGenPrimOp (fsLit "thawSmallArray#") [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy])) +primOpInfo CasSmallArrayOp = mkGenPrimOp (fsLit "casSmallArray#") [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) +primOpInfo NewByteArrayOp_Char = mkGenPrimOp (fsLit "newByteArray#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) +primOpInfo NewPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newPinnedByteArray#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) +primOpInfo NewAlignedPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newAlignedPinnedByteArray#") [deltaTyVar] [intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) +primOpInfo ByteArrayContents_Char = mkGenPrimOp (fsLit "byteArrayContents#") [] [byteArrayPrimTy] (addrPrimTy) +primOpInfo SameMutableByteArrayOp = mkGenPrimOp (fsLit "sameMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy] (intPrimTy) +primOpInfo ShrinkMutableByteArrayOp_Char = mkGenPrimOp (fsLit "shrinkMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo ResizeMutableByteArrayOp_Char = mkGenPrimOp (fsLit "resizeMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) +primOpInfo UnsafeFreezeByteArrayOp = mkGenPrimOp (fsLit "unsafeFreezeByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, byteArrayPrimTy])) +primOpInfo SizeofByteArrayOp = mkGenPrimOp (fsLit "sizeofByteArray#") [] [byteArrayPrimTy] (intPrimTy) +primOpInfo SizeofMutableByteArrayOp = mkGenPrimOp (fsLit "sizeofMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy) +primOpInfo IndexByteArrayOp_Char = mkGenPrimOp (fsLit "indexCharArray#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy) +primOpInfo IndexByteArrayOp_WideChar = mkGenPrimOp (fsLit "indexWideCharArray#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy) +primOpInfo IndexByteArrayOp_Int = mkGenPrimOp (fsLit "indexIntArray#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) +primOpInfo IndexByteArrayOp_Word = mkGenPrimOp (fsLit "indexWordArray#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) +primOpInfo IndexByteArrayOp_Addr = mkGenPrimOp (fsLit "indexAddrArray#") [] [byteArrayPrimTy, intPrimTy] (addrPrimTy) +primOpInfo IndexByteArrayOp_Float = mkGenPrimOp (fsLit "indexFloatArray#") [] [byteArrayPrimTy, intPrimTy] (floatPrimTy) +primOpInfo IndexByteArrayOp_Double = mkGenPrimOp (fsLit "indexDoubleArray#") [] [byteArrayPrimTy, intPrimTy] (doublePrimTy) +primOpInfo IndexByteArrayOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrArray#") [alphaTyVar] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy) +primOpInfo IndexByteArrayOp_Int8 = mkGenPrimOp (fsLit "indexInt8Array#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) +primOpInfo IndexByteArrayOp_Int16 = mkGenPrimOp (fsLit "indexInt16Array#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) +primOpInfo IndexByteArrayOp_Int32 = mkGenPrimOp (fsLit "indexInt32Array#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) +primOpInfo IndexByteArrayOp_Int64 = mkGenPrimOp (fsLit "indexInt64Array#") [] [byteArrayPrimTy, intPrimTy] (int64PrimTy) +primOpInfo IndexByteArrayOp_Word8 = mkGenPrimOp (fsLit "indexWord8Array#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) +primOpInfo IndexByteArrayOp_Word16 = mkGenPrimOp (fsLit "indexWord16Array#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) +primOpInfo IndexByteArrayOp_Word32 = mkGenPrimOp (fsLit "indexWord32Array#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) +primOpInfo IndexByteArrayOp_Word64 = mkGenPrimOp (fsLit "indexWord64Array#") [] [byteArrayPrimTy, intPrimTy] (word64PrimTy) +primOpInfo ReadByteArrayOp_Char = mkGenPrimOp (fsLit "readCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, charPrimTy])) +primOpInfo ReadByteArrayOp_WideChar = mkGenPrimOp (fsLit "readWideCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, charPrimTy])) +primOpInfo ReadByteArrayOp_Int = mkGenPrimOp (fsLit "readIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo ReadByteArrayOp_Word = mkGenPrimOp (fsLit "readWordArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, wordPrimTy])) +primOpInfo ReadByteArrayOp_Addr = mkGenPrimOp (fsLit "readAddrArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, addrPrimTy])) +primOpInfo ReadByteArrayOp_Float = mkGenPrimOp (fsLit "readFloatArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, floatPrimTy])) +primOpInfo ReadByteArrayOp_Double = mkGenPrimOp (fsLit "readDoubleArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, doublePrimTy])) +primOpInfo ReadByteArrayOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrArray#") [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy])) +primOpInfo ReadByteArrayOp_Int8 = mkGenPrimOp (fsLit "readInt8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo ReadByteArrayOp_Int16 = mkGenPrimOp (fsLit "readInt16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo ReadByteArrayOp_Int32 = mkGenPrimOp (fsLit "readInt32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo ReadByteArrayOp_Int64 = mkGenPrimOp (fsLit "readInt64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int64PrimTy])) +primOpInfo ReadByteArrayOp_Word8 = mkGenPrimOp (fsLit "readWord8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, wordPrimTy])) +primOpInfo ReadByteArrayOp_Word16 = mkGenPrimOp (fsLit "readWord16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, wordPrimTy])) +primOpInfo ReadByteArrayOp_Word32 = mkGenPrimOp (fsLit "readWord32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, wordPrimTy])) +primOpInfo ReadByteArrayOp_Word64 = mkGenPrimOp (fsLit "readWord64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word64PrimTy])) +primOpInfo WriteByteArrayOp_Char = mkGenPrimOp (fsLit "writeCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_WideChar = mkGenPrimOp (fsLit "writeWideCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Int = mkGenPrimOp (fsLit "writeIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word = mkGenPrimOp (fsLit "writeWordArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Addr = mkGenPrimOp (fsLit "writeAddrArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Float = mkGenPrimOp (fsLit "writeFloatArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Double = mkGenPrimOp (fsLit "writeDoubleArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrArray#") [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Int8 = mkGenPrimOp (fsLit "writeInt8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Int16 = mkGenPrimOp (fsLit "writeInt16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Int32 = mkGenPrimOp (fsLit "writeInt32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Int64 = mkGenPrimOp (fsLit "writeInt64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word8 = mkGenPrimOp (fsLit "writeWord8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word16 = mkGenPrimOp (fsLit "writeWord16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word32 = mkGenPrimOp (fsLit "writeWord32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteByteArrayOp_Word64 = mkGenPrimOp (fsLit "writeWord64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CopyByteArrayOp = mkGenPrimOp (fsLit "copyByteArray#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CopyMutableByteArrayOp = mkGenPrimOp (fsLit "copyMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CopyByteArrayToAddrOp = mkGenPrimOp (fsLit "copyByteArrayToAddr#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CopyMutableByteArrayToAddrOp = mkGenPrimOp (fsLit "copyMutableByteArrayToAddr#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CopyAddrToByteArrayOp = mkGenPrimOp (fsLit "copyAddrToByteArray#") [deltaTyVar] [addrPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo SetByteArrayOp = mkGenPrimOp (fsLit "setByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo AtomicReadByteArrayOp_Int = mkGenPrimOp (fsLit "atomicReadIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo AtomicWriteByteArrayOp_Int = mkGenPrimOp (fsLit "atomicWriteIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CasByteArrayOp_Int = mkGenPrimOp (fsLit "casIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo FetchAddByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAddIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo FetchSubByteArrayOp_Int = mkGenPrimOp (fsLit "fetchSubIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo FetchAndByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAndIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo FetchNandByteArrayOp_Int = mkGenPrimOp (fsLit "fetchNandIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo FetchOrByteArrayOp_Int = mkGenPrimOp (fsLit "fetchOrIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo FetchXorByteArrayOp_Int = mkGenPrimOp (fsLit "fetchXorIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo NewArrayArrayOp = mkGenPrimOp (fsLit "newArrayArray#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy])) +primOpInfo SameMutableArrayArrayOp = mkGenPrimOp (fsLit "sameMutableArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy] (intPrimTy) +primOpInfo UnsafeFreezeArrayArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkArrayArrayPrimTy])) +primOpInfo SizeofArrayArrayOp = mkGenPrimOp (fsLit "sizeofArrayArray#") [] [mkArrayArrayPrimTy] (intPrimTy) +primOpInfo SizeofMutableArrayArrayOp = mkGenPrimOp (fsLit "sizeofMutableArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy] (intPrimTy) +primOpInfo IndexArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "indexByteArrayArray#") [] [mkArrayArrayPrimTy, intPrimTy] (byteArrayPrimTy) +primOpInfo IndexArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "indexArrayArrayArray#") [] [mkArrayArrayPrimTy, intPrimTy] (mkArrayArrayPrimTy) +primOpInfo ReadArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "readByteArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, byteArrayPrimTy])) +primOpInfo ReadArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "readMutableByteArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) +primOpInfo ReadArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "readArrayArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkArrayArrayPrimTy])) +primOpInfo ReadArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "readMutableArrayArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy])) +primOpInfo WriteArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "writeByteArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "writeMutableByteArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "writeArrayArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkArrayArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "writeMutableArrayArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CopyArrayArrayOp = mkGenPrimOp (fsLit "copyArrayArray#") [deltaTyVar] [mkArrayArrayPrimTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo CopyMutableArrayArrayOp = mkGenPrimOp (fsLit "copyMutableArrayArray#") [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo AddrAddOp = mkGenPrimOp (fsLit "plusAddr#") [] [addrPrimTy, intPrimTy] (addrPrimTy) +primOpInfo AddrSubOp = mkGenPrimOp (fsLit "minusAddr#") [] [addrPrimTy, addrPrimTy] (intPrimTy) +primOpInfo AddrRemOp = mkGenPrimOp (fsLit "remAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) +primOpInfo Addr2IntOp = mkGenPrimOp (fsLit "addr2Int#") [] [addrPrimTy] (intPrimTy) +primOpInfo Int2AddrOp = mkGenPrimOp (fsLit "int2Addr#") [] [intPrimTy] (addrPrimTy) +primOpInfo AddrGtOp = mkCompare (fsLit "gtAddr#") addrPrimTy +primOpInfo AddrGeOp = mkCompare (fsLit "geAddr#") addrPrimTy +primOpInfo AddrEqOp = mkCompare (fsLit "eqAddr#") addrPrimTy +primOpInfo AddrNeOp = mkCompare (fsLit "neAddr#") addrPrimTy +primOpInfo AddrLtOp = mkCompare (fsLit "ltAddr#") addrPrimTy +primOpInfo AddrLeOp = mkCompare (fsLit "leAddr#") addrPrimTy +primOpInfo IndexOffAddrOp_Char = mkGenPrimOp (fsLit "indexCharOffAddr#") [] [addrPrimTy, intPrimTy] (charPrimTy) +primOpInfo IndexOffAddrOp_WideChar = mkGenPrimOp (fsLit "indexWideCharOffAddr#") [] [addrPrimTy, intPrimTy] (charPrimTy) +primOpInfo IndexOffAddrOp_Int = mkGenPrimOp (fsLit "indexIntOffAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) +primOpInfo IndexOffAddrOp_Word = mkGenPrimOp (fsLit "indexWordOffAddr#") [] [addrPrimTy, intPrimTy] (wordPrimTy) +primOpInfo IndexOffAddrOp_Addr = mkGenPrimOp (fsLit "indexAddrOffAddr#") [] [addrPrimTy, intPrimTy] (addrPrimTy) +primOpInfo IndexOffAddrOp_Float = mkGenPrimOp (fsLit "indexFloatOffAddr#") [] [addrPrimTy, intPrimTy] (floatPrimTy) +primOpInfo IndexOffAddrOp_Double = mkGenPrimOp (fsLit "indexDoubleOffAddr#") [] [addrPrimTy, intPrimTy] (doublePrimTy) +primOpInfo IndexOffAddrOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrOffAddr#") [alphaTyVar] [addrPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy) +primOpInfo IndexOffAddrOp_Int8 = mkGenPrimOp (fsLit "indexInt8OffAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) +primOpInfo IndexOffAddrOp_Int16 = mkGenPrimOp (fsLit "indexInt16OffAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) +primOpInfo IndexOffAddrOp_Int32 = mkGenPrimOp (fsLit "indexInt32OffAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy) +primOpInfo IndexOffAddrOp_Int64 = mkGenPrimOp (fsLit "indexInt64OffAddr#") [] [addrPrimTy, intPrimTy] (int64PrimTy) +primOpInfo IndexOffAddrOp_Word8 = mkGenPrimOp (fsLit "indexWord8OffAddr#") [] [addrPrimTy, intPrimTy] (wordPrimTy) +primOpInfo IndexOffAddrOp_Word16 = mkGenPrimOp (fsLit "indexWord16OffAddr#") [] [addrPrimTy, intPrimTy] (wordPrimTy) +primOpInfo IndexOffAddrOp_Word32 = mkGenPrimOp (fsLit "indexWord32OffAddr#") [] [addrPrimTy, intPrimTy] (wordPrimTy) +primOpInfo IndexOffAddrOp_Word64 = mkGenPrimOp (fsLit "indexWord64OffAddr#") [] [addrPrimTy, intPrimTy] (word64PrimTy) +primOpInfo ReadOffAddrOp_Char = mkGenPrimOp (fsLit "readCharOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, charPrimTy])) +primOpInfo ReadOffAddrOp_WideChar = mkGenPrimOp (fsLit "readWideCharOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, charPrimTy])) +primOpInfo ReadOffAddrOp_Int = mkGenPrimOp (fsLit "readIntOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo ReadOffAddrOp_Word = mkGenPrimOp (fsLit "readWordOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, wordPrimTy])) +primOpInfo ReadOffAddrOp_Addr = mkGenPrimOp (fsLit "readAddrOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, addrPrimTy])) +primOpInfo ReadOffAddrOp_Float = mkGenPrimOp (fsLit "readFloatOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, floatPrimTy])) +primOpInfo ReadOffAddrOp_Double = mkGenPrimOp (fsLit "readDoubleOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, doublePrimTy])) +primOpInfo ReadOffAddrOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrOffAddr#") [deltaTyVar, alphaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy])) +primOpInfo ReadOffAddrOp_Int8 = mkGenPrimOp (fsLit "readInt8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo ReadOffAddrOp_Int16 = mkGenPrimOp (fsLit "readInt16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo ReadOffAddrOp_Int32 = mkGenPrimOp (fsLit "readInt32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo ReadOffAddrOp_Int64 = mkGenPrimOp (fsLit "readInt64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int64PrimTy])) +primOpInfo ReadOffAddrOp_Word8 = mkGenPrimOp (fsLit "readWord8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, wordPrimTy])) +primOpInfo ReadOffAddrOp_Word16 = mkGenPrimOp (fsLit "readWord16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, wordPrimTy])) +primOpInfo ReadOffAddrOp_Word32 = mkGenPrimOp (fsLit "readWord32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, wordPrimTy])) +primOpInfo ReadOffAddrOp_Word64 = mkGenPrimOp (fsLit "readWord64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word64PrimTy])) +primOpInfo WriteOffAddrOp_Char = mkGenPrimOp (fsLit "writeCharOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_WideChar = mkGenPrimOp (fsLit "writeWideCharOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Int = mkGenPrimOp (fsLit "writeIntOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Word = mkGenPrimOp (fsLit "writeWordOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Addr = mkGenPrimOp (fsLit "writeAddrOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Float = mkGenPrimOp (fsLit "writeFloatOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Double = mkGenPrimOp (fsLit "writeDoubleOffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrOffAddr#") [alphaTyVar, deltaTyVar] [addrPrimTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Int8 = mkGenPrimOp (fsLit "writeInt8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Int16 = mkGenPrimOp (fsLit "writeInt16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Int32 = mkGenPrimOp (fsLit "writeInt32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Int64 = mkGenPrimOp (fsLit "writeInt64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Word8 = mkGenPrimOp (fsLit "writeWord8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Word16 = mkGenPrimOp (fsLit "writeWord16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Word32 = mkGenPrimOp (fsLit "writeWord32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WriteOffAddrOp_Word64 = mkGenPrimOp (fsLit "writeWord64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo NewMutVarOp = mkGenPrimOp (fsLit "newMutVar#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkMutVarPrimTy deltaTy alphaTy])) +primOpInfo ReadMutVarOp = mkGenPrimOp (fsLit "readMutVar#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, alphaTy])) +primOpInfo WriteMutVarOp = mkGenPrimOp (fsLit "writeMutVar#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo SameMutVarOp = mkGenPrimOp (fsLit "sameMutVar#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkMutVarPrimTy deltaTy alphaTy] (intPrimTy) +primOpInfo AtomicModifyMutVarOp = mkGenPrimOp (fsLit "atomicModifyMutVar#") [deltaTyVar, alphaTyVar, betaTyVar, gammaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkFunTy (alphaTy) (betaTy)), mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, gammaTy])) +primOpInfo CasMutVarOp = mkGenPrimOp (fsLit "casMutVar#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) +primOpInfo CatchOp = mkGenPrimOp (fsLit "catch#") [alphaTyVar, betaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, alphaTy]))), (mkFunTy (betaTy) ((mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, alphaTy])) +primOpInfo RaiseOp = mkGenPrimOp (fsLit "raise#") [alphaTyVar, betaTyVar] [alphaTy] (betaTy) +primOpInfo RaiseIOOp = mkGenPrimOp (fsLit "raiseIO#") [alphaTyVar, betaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, betaTy])) +primOpInfo MaskAsyncExceptionsOp = mkGenPrimOp (fsLit "maskAsyncExceptions#") [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, alphaTy])) +primOpInfo MaskUninterruptibleOp = mkGenPrimOp (fsLit "maskUninterruptible#") [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, alphaTy])) +primOpInfo UnmaskAsyncExceptionsOp = mkGenPrimOp (fsLit "unmaskAsyncExceptions#") [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, alphaTy])) +primOpInfo MaskStatus = mkGenPrimOp (fsLit "getMaskingState#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, intPrimTy])) +primOpInfo AtomicallyOp = mkGenPrimOp (fsLit "atomically#") [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, alphaTy])) +primOpInfo RetryOp = mkGenPrimOp (fsLit "retry#") [alphaTyVar] [mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, alphaTy])) +primOpInfo CatchRetryOp = mkGenPrimOp (fsLit "catchRetry#") [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, alphaTy]))), (mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, alphaTy])) +primOpInfo CatchSTMOp = mkGenPrimOp (fsLit "catchSTM#") [alphaTyVar, betaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, alphaTy]))), (mkFunTy (betaTy) ((mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, alphaTy])) +primOpInfo Check = mkGenPrimOp (fsLit "check#") [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, unitTy])) +primOpInfo NewTVarOp = mkGenPrimOp (fsLit "newTVar#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkTVarPrimTy deltaTy alphaTy])) +primOpInfo ReadTVarOp = mkGenPrimOp (fsLit "readTVar#") [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, alphaTy])) +primOpInfo ReadTVarIOOp = mkGenPrimOp (fsLit "readTVarIO#") [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, alphaTy])) +primOpInfo WriteTVarOp = mkGenPrimOp (fsLit "writeTVar#") [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo SameTVarOp = mkGenPrimOp (fsLit "sameTVar#") [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkTVarPrimTy deltaTy alphaTy] (intPrimTy) +primOpInfo NewMVarOp = mkGenPrimOp (fsLit "newMVar#") [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, mkMVarPrimTy deltaTy alphaTy])) +primOpInfo TakeMVarOp = mkGenPrimOp (fsLit "takeMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, alphaTy])) +primOpInfo TryTakeMVarOp = mkGenPrimOp (fsLit "tryTakeMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) +primOpInfo PutMVarOp = mkGenPrimOp (fsLit "putMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo TryPutMVarOp = mkGenPrimOp (fsLit "tryPutMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo ReadMVarOp = mkGenPrimOp (fsLit "readMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, alphaTy])) +primOpInfo TryReadMVarOp = mkGenPrimOp (fsLit "tryReadMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) +primOpInfo SameMVarOp = mkGenPrimOp (fsLit "sameMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkMVarPrimTy deltaTy alphaTy] (intPrimTy) +primOpInfo IsEmptyMVarOp = mkGenPrimOp (fsLit "isEmptyMVar#") [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo DelayOp = mkGenPrimOp (fsLit "delay#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WaitReadOp = mkGenPrimOp (fsLit "waitRead#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo WaitWriteOp = mkGenPrimOp (fsLit "waitWrite#") [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo ForkOp = mkGenPrimOp (fsLit "fork#") [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, threadIdPrimTy])) +primOpInfo ForkOnOp = mkGenPrimOp (fsLit "forkOn#") [alphaTyVar] [intPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, threadIdPrimTy])) +primOpInfo KillThreadOp = mkGenPrimOp (fsLit "killThread#") [alphaTyVar] [threadIdPrimTy, alphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) +primOpInfo YieldOp = mkGenPrimOp (fsLit "yield#") [] [mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) +primOpInfo MyThreadIdOp = mkGenPrimOp (fsLit "myThreadId#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, threadIdPrimTy])) +primOpInfo LabelThreadOp = mkGenPrimOp (fsLit "labelThread#") [] [threadIdPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) +primOpInfo IsCurrentThreadBoundOp = mkGenPrimOp (fsLit "isCurrentThreadBound#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, intPrimTy])) +primOpInfo NoDuplicateOp = mkGenPrimOp (fsLit "noDuplicate#") [] [mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) +primOpInfo ThreadStatusOp = mkGenPrimOp (fsLit "threadStatus#") [] [threadIdPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, intPrimTy, intPrimTy, intPrimTy])) +primOpInfo MkWeakOp = mkGenPrimOp (fsLit "mkWeak#") [openAlphaTyVar, betaTyVar, gammaTyVar] [openAlphaTy, betaTy, gammaTy, mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy])) +primOpInfo MkWeakNoFinalizerOp = mkGenPrimOp (fsLit "mkWeakNoFinalizer#") [openAlphaTyVar, betaTyVar] [openAlphaTy, betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy])) +primOpInfo AddCFinalizerToWeakOp = mkGenPrimOp (fsLit "addCFinalizerToWeak#") [betaTyVar] [addrPrimTy, addrPrimTy, intPrimTy, addrPrimTy, mkWeakPrimTy betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, intPrimTy])) +primOpInfo DeRefWeakOp = mkGenPrimOp (fsLit "deRefWeak#") [alphaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, intPrimTy, alphaTy])) +primOpInfo FinalizeWeakOp = mkGenPrimOp (fsLit "finalizeWeak#") [alphaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, intPrimTy, (mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, unitTy])))])) +primOpInfo TouchOp = mkGenPrimOp (fsLit "touch#") [openAlphaTyVar] [openAlphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy) +primOpInfo MakeStablePtrOp = mkGenPrimOp (fsLit "makeStablePtr#") [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, mkStablePtrPrimTy alphaTy])) +primOpInfo DeRefStablePtrOp = mkGenPrimOp (fsLit "deRefStablePtr#") [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, alphaTy])) +primOpInfo EqStablePtrOp = mkGenPrimOp (fsLit "eqStablePtr#") [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStablePtrPrimTy alphaTy] (intPrimTy) +primOpInfo MakeStableNameOp = mkGenPrimOp (fsLit "makeStableName#") [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, mkStableNamePrimTy alphaTy])) +primOpInfo EqStableNameOp = mkGenPrimOp (fsLit "eqStableName#") [alphaTyVar, betaTyVar] [mkStableNamePrimTy alphaTy, mkStableNamePrimTy betaTy] (intPrimTy) +primOpInfo StableNameToIntOp = mkGenPrimOp (fsLit "stableNameToInt#") [alphaTyVar] [mkStableNamePrimTy alphaTy] (intPrimTy) +primOpInfo ReallyUnsafePtrEqualityOp = mkGenPrimOp (fsLit "reallyUnsafePtrEquality#") [alphaTyVar] [alphaTy, alphaTy] (intPrimTy) +primOpInfo ParOp = mkGenPrimOp (fsLit "par#") [alphaTyVar] [alphaTy] (intPrimTy) +primOpInfo SparkOp = mkGenPrimOp (fsLit "spark#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, alphaTy])) +primOpInfo SeqOp = mkGenPrimOp (fsLit "seq#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, alphaTy])) +primOpInfo GetSparkOp = mkGenPrimOp (fsLit "getSpark#") [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) +primOpInfo NumSparks = mkGenPrimOp (fsLit "numSparks#") [deltaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo ParGlobalOp = mkGenPrimOp (fsLit "parGlobal#") [alphaTyVar, betaTyVar] [alphaTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, betaTy] (intPrimTy) +primOpInfo ParLocalOp = mkGenPrimOp (fsLit "parLocal#") [alphaTyVar, betaTyVar] [alphaTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, betaTy] (intPrimTy) +primOpInfo ParAtOp = mkGenPrimOp (fsLit "parAt#") [betaTyVar, alphaTyVar, gammaTyVar] [betaTy, alphaTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, gammaTy] (intPrimTy) +primOpInfo ParAtAbsOp = mkGenPrimOp (fsLit "parAtAbs#") [alphaTyVar, betaTyVar] [alphaTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, betaTy] (intPrimTy) +primOpInfo ParAtRelOp = mkGenPrimOp (fsLit "parAtRel#") [alphaTyVar, betaTyVar] [alphaTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, betaTy] (intPrimTy) +primOpInfo ParAtForNowOp = mkGenPrimOp (fsLit "parAtForNow#") [betaTyVar, alphaTyVar, gammaTyVar] [betaTy, alphaTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, gammaTy] (intPrimTy) +primOpInfo DataToTagOp = mkGenPrimOp (fsLit "dataToTag#") [alphaTyVar] [alphaTy] (intPrimTy) +primOpInfo TagToEnumOp = mkGenPrimOp (fsLit "tagToEnum#") [alphaTyVar] [intPrimTy] (alphaTy) +primOpInfo AddrToAnyOp = mkGenPrimOp (fsLit "addrToAny#") [alphaTyVar] [addrPrimTy] ((mkTupleTy UnboxedTuple [alphaTy])) +primOpInfo MkApUpd0_Op = mkGenPrimOp (fsLit "mkApUpd0#") [alphaTyVar] [bcoPrimTy] ((mkTupleTy UnboxedTuple [alphaTy])) +primOpInfo NewBCOOp = mkGenPrimOp (fsLit "newBCO#") [alphaTyVar, deltaTyVar] [byteArrayPrimTy, byteArrayPrimTy, mkArrayPrimTy alphaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, bcoPrimTy])) +primOpInfo UnpackClosureOp = mkGenPrimOp (fsLit "unpackClosure#") [alphaTyVar, betaTyVar] [alphaTy] ((mkTupleTy UnboxedTuple [addrPrimTy, mkArrayPrimTy betaTy, byteArrayPrimTy])) +primOpInfo GetApStackValOp = mkGenPrimOp (fsLit "getApStackVal#") [alphaTyVar, betaTyVar] [alphaTy, intPrimTy] ((mkTupleTy UnboxedTuple [intPrimTy, betaTy])) +primOpInfo GetCCSOfOp = mkGenPrimOp (fsLit "getCCSOf#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, addrPrimTy])) +primOpInfo GetCurrentCCSOp = mkGenPrimOp (fsLit "getCurrentCCS#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, addrPrimTy])) +primOpInfo TraceEventOp = mkGenPrimOp (fsLit "traceEvent#") [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo TraceMarkerOp = mkGenPrimOp (fsLit "traceMarker#") [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecBroadcastOp IntVec 16 W8) = mkGenPrimOp (fsLit "broadcastInt8X16#") [] [intPrimTy] (int8X16PrimTy) +primOpInfo (VecBroadcastOp IntVec 8 W16) = mkGenPrimOp (fsLit "broadcastInt16X8#") [] [intPrimTy] (int16X8PrimTy) +primOpInfo (VecBroadcastOp IntVec 4 W32) = mkGenPrimOp (fsLit "broadcastInt32X4#") [] [intPrimTy] (int32X4PrimTy) +primOpInfo (VecBroadcastOp IntVec 2 W64) = mkGenPrimOp (fsLit "broadcastInt64X2#") [] [int64PrimTy] (int64X2PrimTy) +primOpInfo (VecBroadcastOp IntVec 32 W8) = mkGenPrimOp (fsLit "broadcastInt8X32#") [] [intPrimTy] (int8X32PrimTy) +primOpInfo (VecBroadcastOp IntVec 16 W16) = mkGenPrimOp (fsLit "broadcastInt16X16#") [] [intPrimTy] (int16X16PrimTy) +primOpInfo (VecBroadcastOp IntVec 8 W32) = mkGenPrimOp (fsLit "broadcastInt32X8#") [] [intPrimTy] (int32X8PrimTy) +primOpInfo (VecBroadcastOp IntVec 4 W64) = mkGenPrimOp (fsLit "broadcastInt64X4#") [] [int64PrimTy] (int64X4PrimTy) +primOpInfo (VecBroadcastOp IntVec 64 W8) = mkGenPrimOp (fsLit "broadcastInt8X64#") [] [intPrimTy] (int8X64PrimTy) +primOpInfo (VecBroadcastOp IntVec 32 W16) = mkGenPrimOp (fsLit "broadcastInt16X32#") [] [intPrimTy] (int16X32PrimTy) +primOpInfo (VecBroadcastOp IntVec 16 W32) = mkGenPrimOp (fsLit "broadcastInt32X16#") [] [intPrimTy] (int32X16PrimTy) +primOpInfo (VecBroadcastOp IntVec 8 W64) = mkGenPrimOp (fsLit "broadcastInt64X8#") [] [int64PrimTy] (int64X8PrimTy) +primOpInfo (VecBroadcastOp WordVec 16 W8) = mkGenPrimOp (fsLit "broadcastWord8X16#") [] [wordPrimTy] (word8X16PrimTy) +primOpInfo (VecBroadcastOp WordVec 8 W16) = mkGenPrimOp (fsLit "broadcastWord16X8#") [] [wordPrimTy] (word16X8PrimTy) +primOpInfo (VecBroadcastOp WordVec 4 W32) = mkGenPrimOp (fsLit "broadcastWord32X4#") [] [wordPrimTy] (word32X4PrimTy) +primOpInfo (VecBroadcastOp WordVec 2 W64) = mkGenPrimOp (fsLit "broadcastWord64X2#") [] [word64PrimTy] (word64X2PrimTy) +primOpInfo (VecBroadcastOp WordVec 32 W8) = mkGenPrimOp (fsLit "broadcastWord8X32#") [] [wordPrimTy] (word8X32PrimTy) +primOpInfo (VecBroadcastOp WordVec 16 W16) = mkGenPrimOp (fsLit "broadcastWord16X16#") [] [wordPrimTy] (word16X16PrimTy) +primOpInfo (VecBroadcastOp WordVec 8 W32) = mkGenPrimOp (fsLit "broadcastWord32X8#") [] [wordPrimTy] (word32X8PrimTy) +primOpInfo (VecBroadcastOp WordVec 4 W64) = mkGenPrimOp (fsLit "broadcastWord64X4#") [] [word64PrimTy] (word64X4PrimTy) +primOpInfo (VecBroadcastOp WordVec 64 W8) = mkGenPrimOp (fsLit "broadcastWord8X64#") [] [wordPrimTy] (word8X64PrimTy) +primOpInfo (VecBroadcastOp WordVec 32 W16) = mkGenPrimOp (fsLit "broadcastWord16X32#") [] [wordPrimTy] (word16X32PrimTy) +primOpInfo (VecBroadcastOp WordVec 16 W32) = mkGenPrimOp (fsLit "broadcastWord32X16#") [] [wordPrimTy] (word32X16PrimTy) +primOpInfo (VecBroadcastOp WordVec 8 W64) = mkGenPrimOp (fsLit "broadcastWord64X8#") [] [word64PrimTy] (word64X8PrimTy) +primOpInfo (VecBroadcastOp FloatVec 4 W32) = mkGenPrimOp (fsLit "broadcastFloatX4#") [] [floatPrimTy] (floatX4PrimTy) +primOpInfo (VecBroadcastOp FloatVec 2 W64) = mkGenPrimOp (fsLit "broadcastDoubleX2#") [] [doublePrimTy] (doubleX2PrimTy) +primOpInfo (VecBroadcastOp FloatVec 8 W32) = mkGenPrimOp (fsLit "broadcastFloatX8#") [] [floatPrimTy] (floatX8PrimTy) +primOpInfo (VecBroadcastOp FloatVec 4 W64) = mkGenPrimOp (fsLit "broadcastDoubleX4#") [] [doublePrimTy] (doubleX4PrimTy) +primOpInfo (VecBroadcastOp FloatVec 16 W32) = mkGenPrimOp (fsLit "broadcastFloatX16#") [] [floatPrimTy] (floatX16PrimTy) +primOpInfo (VecBroadcastOp FloatVec 8 W64) = mkGenPrimOp (fsLit "broadcastDoubleX8#") [] [doublePrimTy] (doubleX8PrimTy) +primOpInfo (VecPackOp IntVec 16 W8) = mkGenPrimOp (fsLit "packInt8X16#") [] [(mkTupleTy UnboxedTuple [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X16PrimTy) +primOpInfo (VecPackOp IntVec 8 W16) = mkGenPrimOp (fsLit "packInt16X8#") [] [(mkTupleTy UnboxedTuple [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X8PrimTy) +primOpInfo (VecPackOp IntVec 4 W32) = mkGenPrimOp (fsLit "packInt32X4#") [] [(mkTupleTy UnboxedTuple [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X4PrimTy) +primOpInfo (VecPackOp IntVec 2 W64) = mkGenPrimOp (fsLit "packInt64X2#") [] [(mkTupleTy UnboxedTuple [int64PrimTy, int64PrimTy])] (int64X2PrimTy) +primOpInfo (VecPackOp IntVec 32 W8) = mkGenPrimOp (fsLit "packInt8X32#") [] [(mkTupleTy UnboxedTuple [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X32PrimTy) +primOpInfo (VecPackOp IntVec 16 W16) = mkGenPrimOp (fsLit "packInt16X16#") [] [(mkTupleTy UnboxedTuple [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X16PrimTy) +primOpInfo (VecPackOp IntVec 8 W32) = mkGenPrimOp (fsLit "packInt32X8#") [] [(mkTupleTy UnboxedTuple [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X8PrimTy) +primOpInfo (VecPackOp IntVec 4 W64) = mkGenPrimOp (fsLit "packInt64X4#") [] [(mkTupleTy UnboxedTuple [int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy])] (int64X4PrimTy) +primOpInfo (VecPackOp IntVec 64 W8) = mkGenPrimOp (fsLit "packInt8X64#") [] [(mkTupleTy UnboxedTuple [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X64PrimTy) +primOpInfo (VecPackOp IntVec 32 W16) = mkGenPrimOp (fsLit "packInt16X32#") [] [(mkTupleTy UnboxedTuple [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X32PrimTy) +primOpInfo (VecPackOp IntVec 16 W32) = mkGenPrimOp (fsLit "packInt32X16#") [] [(mkTupleTy UnboxedTuple [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X16PrimTy) +primOpInfo (VecPackOp IntVec 8 W64) = mkGenPrimOp (fsLit "packInt64X8#") [] [(mkTupleTy UnboxedTuple [int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy])] (int64X8PrimTy) +primOpInfo (VecPackOp WordVec 16 W8) = mkGenPrimOp (fsLit "packWord8X16#") [] [(mkTupleTy UnboxedTuple [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X16PrimTy) +primOpInfo (VecPackOp WordVec 8 W16) = mkGenPrimOp (fsLit "packWord16X8#") [] [(mkTupleTy UnboxedTuple [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X8PrimTy) +primOpInfo (VecPackOp WordVec 4 W32) = mkGenPrimOp (fsLit "packWord32X4#") [] [(mkTupleTy UnboxedTuple [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X4PrimTy) +primOpInfo (VecPackOp WordVec 2 W64) = mkGenPrimOp (fsLit "packWord64X2#") [] [(mkTupleTy UnboxedTuple [word64PrimTy, word64PrimTy])] (word64X2PrimTy) +primOpInfo (VecPackOp WordVec 32 W8) = mkGenPrimOp (fsLit "packWord8X32#") [] [(mkTupleTy UnboxedTuple [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X32PrimTy) +primOpInfo (VecPackOp WordVec 16 W16) = mkGenPrimOp (fsLit "packWord16X16#") [] [(mkTupleTy UnboxedTuple [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X16PrimTy) +primOpInfo (VecPackOp WordVec 8 W32) = mkGenPrimOp (fsLit "packWord32X8#") [] [(mkTupleTy UnboxedTuple [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X8PrimTy) +primOpInfo (VecPackOp WordVec 4 W64) = mkGenPrimOp (fsLit "packWord64X4#") [] [(mkTupleTy UnboxedTuple [word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy])] (word64X4PrimTy) +primOpInfo (VecPackOp WordVec 64 W8) = mkGenPrimOp (fsLit "packWord8X64#") [] [(mkTupleTy UnboxedTuple [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X64PrimTy) +primOpInfo (VecPackOp WordVec 32 W16) = mkGenPrimOp (fsLit "packWord16X32#") [] [(mkTupleTy UnboxedTuple [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X32PrimTy) +primOpInfo (VecPackOp WordVec 16 W32) = mkGenPrimOp (fsLit "packWord32X16#") [] [(mkTupleTy UnboxedTuple [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X16PrimTy) +primOpInfo (VecPackOp WordVec 8 W64) = mkGenPrimOp (fsLit "packWord64X8#") [] [(mkTupleTy UnboxedTuple [word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy])] (word64X8PrimTy) +primOpInfo (VecPackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "packFloatX4#") [] [(mkTupleTy UnboxedTuple [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX4PrimTy) +primOpInfo (VecPackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "packDoubleX2#") [] [(mkTupleTy UnboxedTuple [doublePrimTy, doublePrimTy])] (doubleX2PrimTy) +primOpInfo (VecPackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "packFloatX8#") [] [(mkTupleTy UnboxedTuple [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX8PrimTy) +primOpInfo (VecPackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "packDoubleX4#") [] [(mkTupleTy UnboxedTuple [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX4PrimTy) +primOpInfo (VecPackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "packFloatX16#") [] [(mkTupleTy UnboxedTuple [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX16PrimTy) +primOpInfo (VecPackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "packDoubleX8#") [] [(mkTupleTy UnboxedTuple [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX8PrimTy) +primOpInfo (VecUnpackOp IntVec 16 W8) = mkGenPrimOp (fsLit "unpackInt8X16#") [] [int8X16PrimTy] ((mkTupleTy UnboxedTuple [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) +primOpInfo (VecUnpackOp IntVec 8 W16) = mkGenPrimOp (fsLit "unpackInt16X8#") [] [int16X8PrimTy] ((mkTupleTy UnboxedTuple [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) +primOpInfo (VecUnpackOp IntVec 4 W32) = mkGenPrimOp (fsLit "unpackInt32X4#") [] [int32X4PrimTy] ((mkTupleTy UnboxedTuple [intPrimTy, intPrimTy, intPrimTy, intPrimTy])) +primOpInfo (VecUnpackOp IntVec 2 W64) = mkGenPrimOp (fsLit "unpackInt64X2#") [] [int64X2PrimTy] ((mkTupleTy UnboxedTuple [int64PrimTy, int64PrimTy])) +primOpInfo (VecUnpackOp IntVec 32 W8) = mkGenPrimOp (fsLit "unpackInt8X32#") [] [int8X32PrimTy] ((mkTupleTy UnboxedTuple [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) +primOpInfo (VecUnpackOp IntVec 16 W16) = mkGenPrimOp (fsLit "unpackInt16X16#") [] [int16X16PrimTy] ((mkTupleTy UnboxedTuple [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) +primOpInfo (VecUnpackOp IntVec 8 W32) = mkGenPrimOp (fsLit "unpackInt32X8#") [] [int32X8PrimTy] ((mkTupleTy UnboxedTuple [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) +primOpInfo (VecUnpackOp IntVec 4 W64) = mkGenPrimOp (fsLit "unpackInt64X4#") [] [int64X4PrimTy] ((mkTupleTy UnboxedTuple [int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy])) +primOpInfo (VecUnpackOp IntVec 64 W8) = mkGenPrimOp (fsLit "unpackInt8X64#") [] [int8X64PrimTy] ((mkTupleTy UnboxedTuple [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) +primOpInfo (VecUnpackOp IntVec 32 W16) = mkGenPrimOp (fsLit "unpackInt16X32#") [] [int16X32PrimTy] ((mkTupleTy UnboxedTuple [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) +primOpInfo (VecUnpackOp IntVec 16 W32) = mkGenPrimOp (fsLit "unpackInt32X16#") [] [int32X16PrimTy] ((mkTupleTy UnboxedTuple [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])) +primOpInfo (VecUnpackOp IntVec 8 W64) = mkGenPrimOp (fsLit "unpackInt64X8#") [] [int64X8PrimTy] ((mkTupleTy UnboxedTuple [int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy])) +primOpInfo (VecUnpackOp WordVec 16 W8) = mkGenPrimOp (fsLit "unpackWord8X16#") [] [word8X16PrimTy] ((mkTupleTy UnboxedTuple [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) +primOpInfo (VecUnpackOp WordVec 8 W16) = mkGenPrimOp (fsLit "unpackWord16X8#") [] [word16X8PrimTy] ((mkTupleTy UnboxedTuple [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) +primOpInfo (VecUnpackOp WordVec 4 W32) = mkGenPrimOp (fsLit "unpackWord32X4#") [] [word32X4PrimTy] ((mkTupleTy UnboxedTuple [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) +primOpInfo (VecUnpackOp WordVec 2 W64) = mkGenPrimOp (fsLit "unpackWord64X2#") [] [word64X2PrimTy] ((mkTupleTy UnboxedTuple [word64PrimTy, word64PrimTy])) +primOpInfo (VecUnpackOp WordVec 32 W8) = mkGenPrimOp (fsLit "unpackWord8X32#") [] [word8X32PrimTy] ((mkTupleTy UnboxedTuple [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) +primOpInfo (VecUnpackOp WordVec 16 W16) = mkGenPrimOp (fsLit "unpackWord16X16#") [] [word16X16PrimTy] ((mkTupleTy UnboxedTuple [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) +primOpInfo (VecUnpackOp WordVec 8 W32) = mkGenPrimOp (fsLit "unpackWord32X8#") [] [word32X8PrimTy] ((mkTupleTy UnboxedTuple [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) +primOpInfo (VecUnpackOp WordVec 4 W64) = mkGenPrimOp (fsLit "unpackWord64X4#") [] [word64X4PrimTy] ((mkTupleTy UnboxedTuple [word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy])) +primOpInfo (VecUnpackOp WordVec 64 W8) = mkGenPrimOp (fsLit "unpackWord8X64#") [] [word8X64PrimTy] ((mkTupleTy UnboxedTuple [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) +primOpInfo (VecUnpackOp WordVec 32 W16) = mkGenPrimOp (fsLit "unpackWord16X32#") [] [word16X32PrimTy] ((mkTupleTy UnboxedTuple [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) +primOpInfo (VecUnpackOp WordVec 16 W32) = mkGenPrimOp (fsLit "unpackWord32X16#") [] [word32X16PrimTy] ((mkTupleTy UnboxedTuple [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) +primOpInfo (VecUnpackOp WordVec 8 W64) = mkGenPrimOp (fsLit "unpackWord64X8#") [] [word64X8PrimTy] ((mkTupleTy UnboxedTuple [word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy])) +primOpInfo (VecUnpackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "unpackFloatX4#") [] [floatX4PrimTy] ((mkTupleTy UnboxedTuple [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])) +primOpInfo (VecUnpackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "unpackDoubleX2#") [] [doubleX2PrimTy] ((mkTupleTy UnboxedTuple [doublePrimTy, doublePrimTy])) +primOpInfo (VecUnpackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "unpackFloatX8#") [] [floatX8PrimTy] ((mkTupleTy UnboxedTuple [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])) +primOpInfo (VecUnpackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "unpackDoubleX4#") [] [doubleX4PrimTy] ((mkTupleTy UnboxedTuple [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])) +primOpInfo (VecUnpackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "unpackFloatX16#") [] [floatX16PrimTy] ((mkTupleTy UnboxedTuple [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])) +primOpInfo (VecUnpackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "unpackDoubleX8#") [] [doubleX8PrimTy] ((mkTupleTy UnboxedTuple [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])) +primOpInfo (VecInsertOp IntVec 16 W8) = mkGenPrimOp (fsLit "insertInt8X16#") [] [int8X16PrimTy, intPrimTy, intPrimTy] (int8X16PrimTy) +primOpInfo (VecInsertOp IntVec 8 W16) = mkGenPrimOp (fsLit "insertInt16X8#") [] [int16X8PrimTy, intPrimTy, intPrimTy] (int16X8PrimTy) +primOpInfo (VecInsertOp IntVec 4 W32) = mkGenPrimOp (fsLit "insertInt32X4#") [] [int32X4PrimTy, intPrimTy, intPrimTy] (int32X4PrimTy) +primOpInfo (VecInsertOp IntVec 2 W64) = mkGenPrimOp (fsLit "insertInt64X2#") [] [int64X2PrimTy, int64PrimTy, intPrimTy] (int64X2PrimTy) +primOpInfo (VecInsertOp IntVec 32 W8) = mkGenPrimOp (fsLit "insertInt8X32#") [] [int8X32PrimTy, intPrimTy, intPrimTy] (int8X32PrimTy) +primOpInfo (VecInsertOp IntVec 16 W16) = mkGenPrimOp (fsLit "insertInt16X16#") [] [int16X16PrimTy, intPrimTy, intPrimTy] (int16X16PrimTy) +primOpInfo (VecInsertOp IntVec 8 W32) = mkGenPrimOp (fsLit "insertInt32X8#") [] [int32X8PrimTy, intPrimTy, intPrimTy] (int32X8PrimTy) +primOpInfo (VecInsertOp IntVec 4 W64) = mkGenPrimOp (fsLit "insertInt64X4#") [] [int64X4PrimTy, int64PrimTy, intPrimTy] (int64X4PrimTy) +primOpInfo (VecInsertOp IntVec 64 W8) = mkGenPrimOp (fsLit "insertInt8X64#") [] [int8X64PrimTy, intPrimTy, intPrimTy] (int8X64PrimTy) +primOpInfo (VecInsertOp IntVec 32 W16) = mkGenPrimOp (fsLit "insertInt16X32#") [] [int16X32PrimTy, intPrimTy, intPrimTy] (int16X32PrimTy) +primOpInfo (VecInsertOp IntVec 16 W32) = mkGenPrimOp (fsLit "insertInt32X16#") [] [int32X16PrimTy, intPrimTy, intPrimTy] (int32X16PrimTy) +primOpInfo (VecInsertOp IntVec 8 W64) = mkGenPrimOp (fsLit "insertInt64X8#") [] [int64X8PrimTy, int64PrimTy, intPrimTy] (int64X8PrimTy) +primOpInfo (VecInsertOp WordVec 16 W8) = mkGenPrimOp (fsLit "insertWord8X16#") [] [word8X16PrimTy, wordPrimTy, intPrimTy] (word8X16PrimTy) +primOpInfo (VecInsertOp WordVec 8 W16) = mkGenPrimOp (fsLit "insertWord16X8#") [] [word16X8PrimTy, wordPrimTy, intPrimTy] (word16X8PrimTy) +primOpInfo (VecInsertOp WordVec 4 W32) = mkGenPrimOp (fsLit "insertWord32X4#") [] [word32X4PrimTy, wordPrimTy, intPrimTy] (word32X4PrimTy) +primOpInfo (VecInsertOp WordVec 2 W64) = mkGenPrimOp (fsLit "insertWord64X2#") [] [word64X2PrimTy, word64PrimTy, intPrimTy] (word64X2PrimTy) +primOpInfo (VecInsertOp WordVec 32 W8) = mkGenPrimOp (fsLit "insertWord8X32#") [] [word8X32PrimTy, wordPrimTy, intPrimTy] (word8X32PrimTy) +primOpInfo (VecInsertOp WordVec 16 W16) = mkGenPrimOp (fsLit "insertWord16X16#") [] [word16X16PrimTy, wordPrimTy, intPrimTy] (word16X16PrimTy) +primOpInfo (VecInsertOp WordVec 8 W32) = mkGenPrimOp (fsLit "insertWord32X8#") [] [word32X8PrimTy, wordPrimTy, intPrimTy] (word32X8PrimTy) +primOpInfo (VecInsertOp WordVec 4 W64) = mkGenPrimOp (fsLit "insertWord64X4#") [] [word64X4PrimTy, word64PrimTy, intPrimTy] (word64X4PrimTy) +primOpInfo (VecInsertOp WordVec 64 W8) = mkGenPrimOp (fsLit "insertWord8X64#") [] [word8X64PrimTy, wordPrimTy, intPrimTy] (word8X64PrimTy) +primOpInfo (VecInsertOp WordVec 32 W16) = mkGenPrimOp (fsLit "insertWord16X32#") [] [word16X32PrimTy, wordPrimTy, intPrimTy] (word16X32PrimTy) +primOpInfo (VecInsertOp WordVec 16 W32) = mkGenPrimOp (fsLit "insertWord32X16#") [] [word32X16PrimTy, wordPrimTy, intPrimTy] (word32X16PrimTy) +primOpInfo (VecInsertOp WordVec 8 W64) = mkGenPrimOp (fsLit "insertWord64X8#") [] [word64X8PrimTy, word64PrimTy, intPrimTy] (word64X8PrimTy) +primOpInfo (VecInsertOp FloatVec 4 W32) = mkGenPrimOp (fsLit "insertFloatX4#") [] [floatX4PrimTy, floatPrimTy, intPrimTy] (floatX4PrimTy) +primOpInfo (VecInsertOp FloatVec 2 W64) = mkGenPrimOp (fsLit "insertDoubleX2#") [] [doubleX2PrimTy, doublePrimTy, intPrimTy] (doubleX2PrimTy) +primOpInfo (VecInsertOp FloatVec 8 W32) = mkGenPrimOp (fsLit "insertFloatX8#") [] [floatX8PrimTy, floatPrimTy, intPrimTy] (floatX8PrimTy) +primOpInfo (VecInsertOp FloatVec 4 W64) = mkGenPrimOp (fsLit "insertDoubleX4#") [] [doubleX4PrimTy, doublePrimTy, intPrimTy] (doubleX4PrimTy) +primOpInfo (VecInsertOp FloatVec 16 W32) = mkGenPrimOp (fsLit "insertFloatX16#") [] [floatX16PrimTy, floatPrimTy, intPrimTy] (floatX16PrimTy) +primOpInfo (VecInsertOp FloatVec 8 W64) = mkGenPrimOp (fsLit "insertDoubleX8#") [] [doubleX8PrimTy, doublePrimTy, intPrimTy] (doubleX8PrimTy) +primOpInfo (VecAddOp IntVec 16 W8) = mkDyadic (fsLit "plusInt8X16#") int8X16PrimTy +primOpInfo (VecAddOp IntVec 8 W16) = mkDyadic (fsLit "plusInt16X8#") int16X8PrimTy +primOpInfo (VecAddOp IntVec 4 W32) = mkDyadic (fsLit "plusInt32X4#") int32X4PrimTy +primOpInfo (VecAddOp IntVec 2 W64) = mkDyadic (fsLit "plusInt64X2#") int64X2PrimTy +primOpInfo (VecAddOp IntVec 32 W8) = mkDyadic (fsLit "plusInt8X32#") int8X32PrimTy +primOpInfo (VecAddOp IntVec 16 W16) = mkDyadic (fsLit "plusInt16X16#") int16X16PrimTy +primOpInfo (VecAddOp IntVec 8 W32) = mkDyadic (fsLit "plusInt32X8#") int32X8PrimTy +primOpInfo (VecAddOp IntVec 4 W64) = mkDyadic (fsLit "plusInt64X4#") int64X4PrimTy +primOpInfo (VecAddOp IntVec 64 W8) = mkDyadic (fsLit "plusInt8X64#") int8X64PrimTy +primOpInfo (VecAddOp IntVec 32 W16) = mkDyadic (fsLit "plusInt16X32#") int16X32PrimTy +primOpInfo (VecAddOp IntVec 16 W32) = mkDyadic (fsLit "plusInt32X16#") int32X16PrimTy +primOpInfo (VecAddOp IntVec 8 W64) = mkDyadic (fsLit "plusInt64X8#") int64X8PrimTy +primOpInfo (VecAddOp WordVec 16 W8) = mkDyadic (fsLit "plusWord8X16#") word8X16PrimTy +primOpInfo (VecAddOp WordVec 8 W16) = mkDyadic (fsLit "plusWord16X8#") word16X8PrimTy +primOpInfo (VecAddOp WordVec 4 W32) = mkDyadic (fsLit "plusWord32X4#") word32X4PrimTy +primOpInfo (VecAddOp WordVec 2 W64) = mkDyadic (fsLit "plusWord64X2#") word64X2PrimTy +primOpInfo (VecAddOp WordVec 32 W8) = mkDyadic (fsLit "plusWord8X32#") word8X32PrimTy +primOpInfo (VecAddOp WordVec 16 W16) = mkDyadic (fsLit "plusWord16X16#") word16X16PrimTy +primOpInfo (VecAddOp WordVec 8 W32) = mkDyadic (fsLit "plusWord32X8#") word32X8PrimTy +primOpInfo (VecAddOp WordVec 4 W64) = mkDyadic (fsLit "plusWord64X4#") word64X4PrimTy +primOpInfo (VecAddOp WordVec 64 W8) = mkDyadic (fsLit "plusWord8X64#") word8X64PrimTy +primOpInfo (VecAddOp WordVec 32 W16) = mkDyadic (fsLit "plusWord16X32#") word16X32PrimTy +primOpInfo (VecAddOp WordVec 16 W32) = mkDyadic (fsLit "plusWord32X16#") word32X16PrimTy +primOpInfo (VecAddOp WordVec 8 W64) = mkDyadic (fsLit "plusWord64X8#") word64X8PrimTy +primOpInfo (VecAddOp FloatVec 4 W32) = mkDyadic (fsLit "plusFloatX4#") floatX4PrimTy +primOpInfo (VecAddOp FloatVec 2 W64) = mkDyadic (fsLit "plusDoubleX2#") doubleX2PrimTy +primOpInfo (VecAddOp FloatVec 8 W32) = mkDyadic (fsLit "plusFloatX8#") floatX8PrimTy +primOpInfo (VecAddOp FloatVec 4 W64) = mkDyadic (fsLit "plusDoubleX4#") doubleX4PrimTy +primOpInfo (VecAddOp FloatVec 16 W32) = mkDyadic (fsLit "plusFloatX16#") floatX16PrimTy +primOpInfo (VecAddOp FloatVec 8 W64) = mkDyadic (fsLit "plusDoubleX8#") doubleX8PrimTy +primOpInfo (VecSubOp IntVec 16 W8) = mkDyadic (fsLit "minusInt8X16#") int8X16PrimTy +primOpInfo (VecSubOp IntVec 8 W16) = mkDyadic (fsLit "minusInt16X8#") int16X8PrimTy +primOpInfo (VecSubOp IntVec 4 W32) = mkDyadic (fsLit "minusInt32X4#") int32X4PrimTy +primOpInfo (VecSubOp IntVec 2 W64) = mkDyadic (fsLit "minusInt64X2#") int64X2PrimTy +primOpInfo (VecSubOp IntVec 32 W8) = mkDyadic (fsLit "minusInt8X32#") int8X32PrimTy +primOpInfo (VecSubOp IntVec 16 W16) = mkDyadic (fsLit "minusInt16X16#") int16X16PrimTy +primOpInfo (VecSubOp IntVec 8 W32) = mkDyadic (fsLit "minusInt32X8#") int32X8PrimTy +primOpInfo (VecSubOp IntVec 4 W64) = mkDyadic (fsLit "minusInt64X4#") int64X4PrimTy +primOpInfo (VecSubOp IntVec 64 W8) = mkDyadic (fsLit "minusInt8X64#") int8X64PrimTy +primOpInfo (VecSubOp IntVec 32 W16) = mkDyadic (fsLit "minusInt16X32#") int16X32PrimTy +primOpInfo (VecSubOp IntVec 16 W32) = mkDyadic (fsLit "minusInt32X16#") int32X16PrimTy +primOpInfo (VecSubOp IntVec 8 W64) = mkDyadic (fsLit "minusInt64X8#") int64X8PrimTy +primOpInfo (VecSubOp WordVec 16 W8) = mkDyadic (fsLit "minusWord8X16#") word8X16PrimTy +primOpInfo (VecSubOp WordVec 8 W16) = mkDyadic (fsLit "minusWord16X8#") word16X8PrimTy +primOpInfo (VecSubOp WordVec 4 W32) = mkDyadic (fsLit "minusWord32X4#") word32X4PrimTy +primOpInfo (VecSubOp WordVec 2 W64) = mkDyadic (fsLit "minusWord64X2#") word64X2PrimTy +primOpInfo (VecSubOp WordVec 32 W8) = mkDyadic (fsLit "minusWord8X32#") word8X32PrimTy +primOpInfo (VecSubOp WordVec 16 W16) = mkDyadic (fsLit "minusWord16X16#") word16X16PrimTy +primOpInfo (VecSubOp WordVec 8 W32) = mkDyadic (fsLit "minusWord32X8#") word32X8PrimTy +primOpInfo (VecSubOp WordVec 4 W64) = mkDyadic (fsLit "minusWord64X4#") word64X4PrimTy +primOpInfo (VecSubOp WordVec 64 W8) = mkDyadic (fsLit "minusWord8X64#") word8X64PrimTy +primOpInfo (VecSubOp WordVec 32 W16) = mkDyadic (fsLit "minusWord16X32#") word16X32PrimTy +primOpInfo (VecSubOp WordVec 16 W32) = mkDyadic (fsLit "minusWord32X16#") word32X16PrimTy +primOpInfo (VecSubOp WordVec 8 W64) = mkDyadic (fsLit "minusWord64X8#") word64X8PrimTy +primOpInfo (VecSubOp FloatVec 4 W32) = mkDyadic (fsLit "minusFloatX4#") floatX4PrimTy +primOpInfo (VecSubOp FloatVec 2 W64) = mkDyadic (fsLit "minusDoubleX2#") doubleX2PrimTy +primOpInfo (VecSubOp FloatVec 8 W32) = mkDyadic (fsLit "minusFloatX8#") floatX8PrimTy +primOpInfo (VecSubOp FloatVec 4 W64) = mkDyadic (fsLit "minusDoubleX4#") doubleX4PrimTy +primOpInfo (VecSubOp FloatVec 16 W32) = mkDyadic (fsLit "minusFloatX16#") floatX16PrimTy +primOpInfo (VecSubOp FloatVec 8 W64) = mkDyadic (fsLit "minusDoubleX8#") doubleX8PrimTy +primOpInfo (VecMulOp IntVec 16 W8) = mkDyadic (fsLit "timesInt8X16#") int8X16PrimTy +primOpInfo (VecMulOp IntVec 8 W16) = mkDyadic (fsLit "timesInt16X8#") int16X8PrimTy +primOpInfo (VecMulOp IntVec 4 W32) = mkDyadic (fsLit "timesInt32X4#") int32X4PrimTy +primOpInfo (VecMulOp IntVec 2 W64) = mkDyadic (fsLit "timesInt64X2#") int64X2PrimTy +primOpInfo (VecMulOp IntVec 32 W8) = mkDyadic (fsLit "timesInt8X32#") int8X32PrimTy +primOpInfo (VecMulOp IntVec 16 W16) = mkDyadic (fsLit "timesInt16X16#") int16X16PrimTy +primOpInfo (VecMulOp IntVec 8 W32) = mkDyadic (fsLit "timesInt32X8#") int32X8PrimTy +primOpInfo (VecMulOp IntVec 4 W64) = mkDyadic (fsLit "timesInt64X4#") int64X4PrimTy +primOpInfo (VecMulOp IntVec 64 W8) = mkDyadic (fsLit "timesInt8X64#") int8X64PrimTy +primOpInfo (VecMulOp IntVec 32 W16) = mkDyadic (fsLit "timesInt16X32#") int16X32PrimTy +primOpInfo (VecMulOp IntVec 16 W32) = mkDyadic (fsLit "timesInt32X16#") int32X16PrimTy +primOpInfo (VecMulOp IntVec 8 W64) = mkDyadic (fsLit "timesInt64X8#") int64X8PrimTy +primOpInfo (VecMulOp WordVec 16 W8) = mkDyadic (fsLit "timesWord8X16#") word8X16PrimTy +primOpInfo (VecMulOp WordVec 8 W16) = mkDyadic (fsLit "timesWord16X8#") word16X8PrimTy +primOpInfo (VecMulOp WordVec 4 W32) = mkDyadic (fsLit "timesWord32X4#") word32X4PrimTy +primOpInfo (VecMulOp WordVec 2 W64) = mkDyadic (fsLit "timesWord64X2#") word64X2PrimTy +primOpInfo (VecMulOp WordVec 32 W8) = mkDyadic (fsLit "timesWord8X32#") word8X32PrimTy +primOpInfo (VecMulOp WordVec 16 W16) = mkDyadic (fsLit "timesWord16X16#") word16X16PrimTy +primOpInfo (VecMulOp WordVec 8 W32) = mkDyadic (fsLit "timesWord32X8#") word32X8PrimTy +primOpInfo (VecMulOp WordVec 4 W64) = mkDyadic (fsLit "timesWord64X4#") word64X4PrimTy +primOpInfo (VecMulOp WordVec 64 W8) = mkDyadic (fsLit "timesWord8X64#") word8X64PrimTy +primOpInfo (VecMulOp WordVec 32 W16) = mkDyadic (fsLit "timesWord16X32#") word16X32PrimTy +primOpInfo (VecMulOp WordVec 16 W32) = mkDyadic (fsLit "timesWord32X16#") word32X16PrimTy +primOpInfo (VecMulOp WordVec 8 W64) = mkDyadic (fsLit "timesWord64X8#") word64X8PrimTy +primOpInfo (VecMulOp FloatVec 4 W32) = mkDyadic (fsLit "timesFloatX4#") floatX4PrimTy +primOpInfo (VecMulOp FloatVec 2 W64) = mkDyadic (fsLit "timesDoubleX2#") doubleX2PrimTy +primOpInfo (VecMulOp FloatVec 8 W32) = mkDyadic (fsLit "timesFloatX8#") floatX8PrimTy +primOpInfo (VecMulOp FloatVec 4 W64) = mkDyadic (fsLit "timesDoubleX4#") doubleX4PrimTy +primOpInfo (VecMulOp FloatVec 16 W32) = mkDyadic (fsLit "timesFloatX16#") floatX16PrimTy +primOpInfo (VecMulOp FloatVec 8 W64) = mkDyadic (fsLit "timesDoubleX8#") doubleX8PrimTy +primOpInfo (VecDivOp FloatVec 4 W32) = mkDyadic (fsLit "divideFloatX4#") floatX4PrimTy +primOpInfo (VecDivOp FloatVec 2 W64) = mkDyadic (fsLit "divideDoubleX2#") doubleX2PrimTy +primOpInfo (VecDivOp FloatVec 8 W32) = mkDyadic (fsLit "divideFloatX8#") floatX8PrimTy +primOpInfo (VecDivOp FloatVec 4 W64) = mkDyadic (fsLit "divideDoubleX4#") doubleX4PrimTy +primOpInfo (VecDivOp FloatVec 16 W32) = mkDyadic (fsLit "divideFloatX16#") floatX16PrimTy +primOpInfo (VecDivOp FloatVec 8 W64) = mkDyadic (fsLit "divideDoubleX8#") doubleX8PrimTy +primOpInfo (VecQuotOp IntVec 16 W8) = mkDyadic (fsLit "quotInt8X16#") int8X16PrimTy +primOpInfo (VecQuotOp IntVec 8 W16) = mkDyadic (fsLit "quotInt16X8#") int16X8PrimTy +primOpInfo (VecQuotOp IntVec 4 W32) = mkDyadic (fsLit "quotInt32X4#") int32X4PrimTy +primOpInfo (VecQuotOp IntVec 2 W64) = mkDyadic (fsLit "quotInt64X2#") int64X2PrimTy +primOpInfo (VecQuotOp IntVec 32 W8) = mkDyadic (fsLit "quotInt8X32#") int8X32PrimTy +primOpInfo (VecQuotOp IntVec 16 W16) = mkDyadic (fsLit "quotInt16X16#") int16X16PrimTy +primOpInfo (VecQuotOp IntVec 8 W32) = mkDyadic (fsLit "quotInt32X8#") int32X8PrimTy +primOpInfo (VecQuotOp IntVec 4 W64) = mkDyadic (fsLit "quotInt64X4#") int64X4PrimTy +primOpInfo (VecQuotOp IntVec 64 W8) = mkDyadic (fsLit "quotInt8X64#") int8X64PrimTy +primOpInfo (VecQuotOp IntVec 32 W16) = mkDyadic (fsLit "quotInt16X32#") int16X32PrimTy +primOpInfo (VecQuotOp IntVec 16 W32) = mkDyadic (fsLit "quotInt32X16#") int32X16PrimTy +primOpInfo (VecQuotOp IntVec 8 W64) = mkDyadic (fsLit "quotInt64X8#") int64X8PrimTy +primOpInfo (VecQuotOp WordVec 16 W8) = mkDyadic (fsLit "quotWord8X16#") word8X16PrimTy +primOpInfo (VecQuotOp WordVec 8 W16) = mkDyadic (fsLit "quotWord16X8#") word16X8PrimTy +primOpInfo (VecQuotOp WordVec 4 W32) = mkDyadic (fsLit "quotWord32X4#") word32X4PrimTy +primOpInfo (VecQuotOp WordVec 2 W64) = mkDyadic (fsLit "quotWord64X2#") word64X2PrimTy +primOpInfo (VecQuotOp WordVec 32 W8) = mkDyadic (fsLit "quotWord8X32#") word8X32PrimTy +primOpInfo (VecQuotOp WordVec 16 W16) = mkDyadic (fsLit "quotWord16X16#") word16X16PrimTy +primOpInfo (VecQuotOp WordVec 8 W32) = mkDyadic (fsLit "quotWord32X8#") word32X8PrimTy +primOpInfo (VecQuotOp WordVec 4 W64) = mkDyadic (fsLit "quotWord64X4#") word64X4PrimTy +primOpInfo (VecQuotOp WordVec 64 W8) = mkDyadic (fsLit "quotWord8X64#") word8X64PrimTy +primOpInfo (VecQuotOp WordVec 32 W16) = mkDyadic (fsLit "quotWord16X32#") word16X32PrimTy +primOpInfo (VecQuotOp WordVec 16 W32) = mkDyadic (fsLit "quotWord32X16#") word32X16PrimTy +primOpInfo (VecQuotOp WordVec 8 W64) = mkDyadic (fsLit "quotWord64X8#") word64X8PrimTy +primOpInfo (VecRemOp IntVec 16 W8) = mkDyadic (fsLit "remInt8X16#") int8X16PrimTy +primOpInfo (VecRemOp IntVec 8 W16) = mkDyadic (fsLit "remInt16X8#") int16X8PrimTy +primOpInfo (VecRemOp IntVec 4 W32) = mkDyadic (fsLit "remInt32X4#") int32X4PrimTy +primOpInfo (VecRemOp IntVec 2 W64) = mkDyadic (fsLit "remInt64X2#") int64X2PrimTy +primOpInfo (VecRemOp IntVec 32 W8) = mkDyadic (fsLit "remInt8X32#") int8X32PrimTy +primOpInfo (VecRemOp IntVec 16 W16) = mkDyadic (fsLit "remInt16X16#") int16X16PrimTy +primOpInfo (VecRemOp IntVec 8 W32) = mkDyadic (fsLit "remInt32X8#") int32X8PrimTy +primOpInfo (VecRemOp IntVec 4 W64) = mkDyadic (fsLit "remInt64X4#") int64X4PrimTy +primOpInfo (VecRemOp IntVec 64 W8) = mkDyadic (fsLit "remInt8X64#") int8X64PrimTy +primOpInfo (VecRemOp IntVec 32 W16) = mkDyadic (fsLit "remInt16X32#") int16X32PrimTy +primOpInfo (VecRemOp IntVec 16 W32) = mkDyadic (fsLit "remInt32X16#") int32X16PrimTy +primOpInfo (VecRemOp IntVec 8 W64) = mkDyadic (fsLit "remInt64X8#") int64X8PrimTy +primOpInfo (VecRemOp WordVec 16 W8) = mkDyadic (fsLit "remWord8X16#") word8X16PrimTy +primOpInfo (VecRemOp WordVec 8 W16) = mkDyadic (fsLit "remWord16X8#") word16X8PrimTy +primOpInfo (VecRemOp WordVec 4 W32) = mkDyadic (fsLit "remWord32X4#") word32X4PrimTy +primOpInfo (VecRemOp WordVec 2 W64) = mkDyadic (fsLit "remWord64X2#") word64X2PrimTy +primOpInfo (VecRemOp WordVec 32 W8) = mkDyadic (fsLit "remWord8X32#") word8X32PrimTy +primOpInfo (VecRemOp WordVec 16 W16) = mkDyadic (fsLit "remWord16X16#") word16X16PrimTy +primOpInfo (VecRemOp WordVec 8 W32) = mkDyadic (fsLit "remWord32X8#") word32X8PrimTy +primOpInfo (VecRemOp WordVec 4 W64) = mkDyadic (fsLit "remWord64X4#") word64X4PrimTy +primOpInfo (VecRemOp WordVec 64 W8) = mkDyadic (fsLit "remWord8X64#") word8X64PrimTy +primOpInfo (VecRemOp WordVec 32 W16) = mkDyadic (fsLit "remWord16X32#") word16X32PrimTy +primOpInfo (VecRemOp WordVec 16 W32) = mkDyadic (fsLit "remWord32X16#") word32X16PrimTy +primOpInfo (VecRemOp WordVec 8 W64) = mkDyadic (fsLit "remWord64X8#") word64X8PrimTy +primOpInfo (VecNegOp IntVec 16 W8) = mkMonadic (fsLit "negateInt8X16#") int8X16PrimTy +primOpInfo (VecNegOp IntVec 8 W16) = mkMonadic (fsLit "negateInt16X8#") int16X8PrimTy +primOpInfo (VecNegOp IntVec 4 W32) = mkMonadic (fsLit "negateInt32X4#") int32X4PrimTy +primOpInfo (VecNegOp IntVec 2 W64) = mkMonadic (fsLit "negateInt64X2#") int64X2PrimTy +primOpInfo (VecNegOp IntVec 32 W8) = mkMonadic (fsLit "negateInt8X32#") int8X32PrimTy +primOpInfo (VecNegOp IntVec 16 W16) = mkMonadic (fsLit "negateInt16X16#") int16X16PrimTy +primOpInfo (VecNegOp IntVec 8 W32) = mkMonadic (fsLit "negateInt32X8#") int32X8PrimTy +primOpInfo (VecNegOp IntVec 4 W64) = mkMonadic (fsLit "negateInt64X4#") int64X4PrimTy +primOpInfo (VecNegOp IntVec 64 W8) = mkMonadic (fsLit "negateInt8X64#") int8X64PrimTy +primOpInfo (VecNegOp IntVec 32 W16) = mkMonadic (fsLit "negateInt16X32#") int16X32PrimTy +primOpInfo (VecNegOp IntVec 16 W32) = mkMonadic (fsLit "negateInt32X16#") int32X16PrimTy +primOpInfo (VecNegOp IntVec 8 W64) = mkMonadic (fsLit "negateInt64X8#") int64X8PrimTy +primOpInfo (VecNegOp FloatVec 4 W32) = mkMonadic (fsLit "negateFloatX4#") floatX4PrimTy +primOpInfo (VecNegOp FloatVec 2 W64) = mkMonadic (fsLit "negateDoubleX2#") doubleX2PrimTy +primOpInfo (VecNegOp FloatVec 8 W32) = mkMonadic (fsLit "negateFloatX8#") floatX8PrimTy +primOpInfo (VecNegOp FloatVec 4 W64) = mkMonadic (fsLit "negateDoubleX4#") doubleX4PrimTy +primOpInfo (VecNegOp FloatVec 16 W32) = mkMonadic (fsLit "negateFloatX16#") floatX16PrimTy +primOpInfo (VecNegOp FloatVec 8 W64) = mkMonadic (fsLit "negateDoubleX8#") doubleX8PrimTy +primOpInfo (VecIndexByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16Array#") [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy) +primOpInfo (VecIndexByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8Array#") [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy) +primOpInfo (VecIndexByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4Array#") [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy) +primOpInfo (VecIndexByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2Array#") [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy) +primOpInfo (VecIndexByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32Array#") [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy) +primOpInfo (VecIndexByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16Array#") [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy) +primOpInfo (VecIndexByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8Array#") [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy) +primOpInfo (VecIndexByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4Array#") [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy) +primOpInfo (VecIndexByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64Array#") [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy) +primOpInfo (VecIndexByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32Array#") [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy) +primOpInfo (VecIndexByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16Array#") [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy) +primOpInfo (VecIndexByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8Array#") [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16Array#") [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8Array#") [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4Array#") [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2Array#") [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32Array#") [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16Array#") [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8Array#") [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4Array#") [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64Array#") [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32Array#") [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16Array#") [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy) +primOpInfo (VecIndexByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8Array#") [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy) +primOpInfo (VecIndexByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4Array#") [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy) +primOpInfo (VecIndexByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2Array#") [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy) +primOpInfo (VecIndexByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8Array#") [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy) +primOpInfo (VecIndexByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4Array#") [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy) +primOpInfo (VecIndexByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16Array#") [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy) +primOpInfo (VecIndexByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8Array#") [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy) +primOpInfo (VecReadByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int8X16PrimTy])) +primOpInfo (VecReadByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int16X8PrimTy])) +primOpInfo (VecReadByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int32X4PrimTy])) +primOpInfo (VecReadByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int64X2PrimTy])) +primOpInfo (VecReadByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int8X32PrimTy])) +primOpInfo (VecReadByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int16X16PrimTy])) +primOpInfo (VecReadByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int32X8PrimTy])) +primOpInfo (VecReadByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int64X4PrimTy])) +primOpInfo (VecReadByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int8X64PrimTy])) +primOpInfo (VecReadByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int16X32PrimTy])) +primOpInfo (VecReadByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int32X16PrimTy])) +primOpInfo (VecReadByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int64X8PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word8X16PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word16X8PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word32X4PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word64X2PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word8X32PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word16X16PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word32X8PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word64X4PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word8X64PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word16X32PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word32X16PrimTy])) +primOpInfo (VecReadByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word64X8PrimTy])) +primOpInfo (VecReadByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, floatX4PrimTy])) +primOpInfo (VecReadByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, doubleX2PrimTy])) +primOpInfo (VecReadByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, floatX8PrimTy])) +primOpInfo (VecReadByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, doubleX4PrimTy])) +primOpInfo (VecReadByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, floatX16PrimTy])) +primOpInfo (VecReadByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, doubleX8PrimTy])) +primOpInfo (VecWriteByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecIndexOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16OffAddr#") [] [addrPrimTy, intPrimTy] (int8X16PrimTy) +primOpInfo (VecIndexOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8OffAddr#") [] [addrPrimTy, intPrimTy] (int16X8PrimTy) +primOpInfo (VecIndexOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4OffAddr#") [] [addrPrimTy, intPrimTy] (int32X4PrimTy) +primOpInfo (VecIndexOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2OffAddr#") [] [addrPrimTy, intPrimTy] (int64X2PrimTy) +primOpInfo (VecIndexOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32OffAddr#") [] [addrPrimTy, intPrimTy] (int8X32PrimTy) +primOpInfo (VecIndexOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16OffAddr#") [] [addrPrimTy, intPrimTy] (int16X16PrimTy) +primOpInfo (VecIndexOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8OffAddr#") [] [addrPrimTy, intPrimTy] (int32X8PrimTy) +primOpInfo (VecIndexOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4OffAddr#") [] [addrPrimTy, intPrimTy] (int64X4PrimTy) +primOpInfo (VecIndexOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64OffAddr#") [] [addrPrimTy, intPrimTy] (int8X64PrimTy) +primOpInfo (VecIndexOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32OffAddr#") [] [addrPrimTy, intPrimTy] (int16X32PrimTy) +primOpInfo (VecIndexOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16OffAddr#") [] [addrPrimTy, intPrimTy] (int32X16PrimTy) +primOpInfo (VecIndexOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8OffAddr#") [] [addrPrimTy, intPrimTy] (int64X8PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16OffAddr#") [] [addrPrimTy, intPrimTy] (word8X16PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8OffAddr#") [] [addrPrimTy, intPrimTy] (word16X8PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4OffAddr#") [] [addrPrimTy, intPrimTy] (word32X4PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2OffAddr#") [] [addrPrimTy, intPrimTy] (word64X2PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32OffAddr#") [] [addrPrimTy, intPrimTy] (word8X32PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16OffAddr#") [] [addrPrimTy, intPrimTy] (word16X16PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8OffAddr#") [] [addrPrimTy, intPrimTy] (word32X8PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4OffAddr#") [] [addrPrimTy, intPrimTy] (word64X4PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64OffAddr#") [] [addrPrimTy, intPrimTy] (word8X64PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32OffAddr#") [] [addrPrimTy, intPrimTy] (word16X32PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16OffAddr#") [] [addrPrimTy, intPrimTy] (word32X16PrimTy) +primOpInfo (VecIndexOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8OffAddr#") [] [addrPrimTy, intPrimTy] (word64X8PrimTy) +primOpInfo (VecIndexOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4OffAddr#") [] [addrPrimTy, intPrimTy] (floatX4PrimTy) +primOpInfo (VecIndexOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2OffAddr#") [] [addrPrimTy, intPrimTy] (doubleX2PrimTy) +primOpInfo (VecIndexOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8OffAddr#") [] [addrPrimTy, intPrimTy] (floatX8PrimTy) +primOpInfo (VecIndexOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4OffAddr#") [] [addrPrimTy, intPrimTy] (doubleX4PrimTy) +primOpInfo (VecIndexOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16OffAddr#") [] [addrPrimTy, intPrimTy] (floatX16PrimTy) +primOpInfo (VecIndexOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8OffAddr#") [] [addrPrimTy, intPrimTy] (doubleX8PrimTy) +primOpInfo (VecReadOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int8X16PrimTy])) +primOpInfo (VecReadOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int16X8PrimTy])) +primOpInfo (VecReadOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int32X4PrimTy])) +primOpInfo (VecReadOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int64X2PrimTy])) +primOpInfo (VecReadOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int8X32PrimTy])) +primOpInfo (VecReadOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int16X16PrimTy])) +primOpInfo (VecReadOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int32X8PrimTy])) +primOpInfo (VecReadOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int64X4PrimTy])) +primOpInfo (VecReadOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int8X64PrimTy])) +primOpInfo (VecReadOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int16X32PrimTy])) +primOpInfo (VecReadOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int32X16PrimTy])) +primOpInfo (VecReadOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int64X8PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word8X16PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word16X8PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word32X4PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word64X2PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word8X32PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word16X16PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word32X8PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word64X4PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word8X64PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word16X32PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word32X16PrimTy])) +primOpInfo (VecReadOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word64X8PrimTy])) +primOpInfo (VecReadOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, floatX4PrimTy])) +primOpInfo (VecReadOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, doubleX2PrimTy])) +primOpInfo (VecReadOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, floatX8PrimTy])) +primOpInfo (VecReadOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, doubleX4PrimTy])) +primOpInfo (VecReadOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, floatX16PrimTy])) +primOpInfo (VecReadOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, doubleX8PrimTy])) +primOpInfo (VecWriteOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X16#") [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X8#") [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X4#") [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X2#") [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X32#") [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X16#") [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X8#") [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X4#") [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X64#") [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X32#") [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X16#") [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy) +primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X8#") [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X16#") [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X8#") [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X4#") [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X2#") [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X32#") [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X16#") [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X8#") [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X4#") [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X64#") [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X32#") [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X16#") [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy) +primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X8#") [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy) +primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX4#") [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy) +primOpInfo (VecIndexScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX2#") [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy) +primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX8#") [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy) +primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX4#") [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy) +primOpInfo (VecIndexScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX16#") [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy) +primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX8#") [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy) +primOpInfo (VecReadScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int8X16PrimTy])) +primOpInfo (VecReadScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int16X8PrimTy])) +primOpInfo (VecReadScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int32X4PrimTy])) +primOpInfo (VecReadScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int64X2PrimTy])) +primOpInfo (VecReadScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int8X32PrimTy])) +primOpInfo (VecReadScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int16X16PrimTy])) +primOpInfo (VecReadScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int32X8PrimTy])) +primOpInfo (VecReadScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int64X4PrimTy])) +primOpInfo (VecReadScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int8X64PrimTy])) +primOpInfo (VecReadScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int16X32PrimTy])) +primOpInfo (VecReadScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int32X16PrimTy])) +primOpInfo (VecReadScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int64X8PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word8X16PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word16X8PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word32X4PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word64X2PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word8X32PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word16X16PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word32X8PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word64X4PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word8X64PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word16X32PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word32X16PrimTy])) +primOpInfo (VecReadScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word64X8PrimTy])) +primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, floatX4PrimTy])) +primOpInfo (VecReadScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, doubleX2PrimTy])) +primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, floatX8PrimTy])) +primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, doubleX4PrimTy])) +primOpInfo (VecReadScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, floatX16PrimTy])) +primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, doubleX8PrimTy])) +primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX4#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX8#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X16#") [] [addrPrimTy, intPrimTy] (int8X16PrimTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X8#") [] [addrPrimTy, intPrimTy] (int16X8PrimTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X4#") [] [addrPrimTy, intPrimTy] (int32X4PrimTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X2#") [] [addrPrimTy, intPrimTy] (int64X2PrimTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X32#") [] [addrPrimTy, intPrimTy] (int8X32PrimTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X16#") [] [addrPrimTy, intPrimTy] (int16X16PrimTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X8#") [] [addrPrimTy, intPrimTy] (int32X8PrimTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X4#") [] [addrPrimTy, intPrimTy] (int64X4PrimTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X64#") [] [addrPrimTy, intPrimTy] (int8X64PrimTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X32#") [] [addrPrimTy, intPrimTy] (int16X32PrimTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X16#") [] [addrPrimTy, intPrimTy] (int32X16PrimTy) +primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X8#") [] [addrPrimTy, intPrimTy] (int64X8PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X16#") [] [addrPrimTy, intPrimTy] (word8X16PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X8#") [] [addrPrimTy, intPrimTy] (word16X8PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X4#") [] [addrPrimTy, intPrimTy] (word32X4PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X2#") [] [addrPrimTy, intPrimTy] (word64X2PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X32#") [] [addrPrimTy, intPrimTy] (word8X32PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X16#") [] [addrPrimTy, intPrimTy] (word16X16PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X8#") [] [addrPrimTy, intPrimTy] (word32X8PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X4#") [] [addrPrimTy, intPrimTy] (word64X4PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X64#") [] [addrPrimTy, intPrimTy] (word8X64PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X32#") [] [addrPrimTy, intPrimTy] (word16X32PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X16#") [] [addrPrimTy, intPrimTy] (word32X16PrimTy) +primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X8#") [] [addrPrimTy, intPrimTy] (word64X8PrimTy) +primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX4#") [] [addrPrimTy, intPrimTy] (floatX4PrimTy) +primOpInfo (VecIndexScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX2#") [] [addrPrimTy, intPrimTy] (doubleX2PrimTy) +primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX8#") [] [addrPrimTy, intPrimTy] (floatX8PrimTy) +primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX4#") [] [addrPrimTy, intPrimTy] (doubleX4PrimTy) +primOpInfo (VecIndexScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX16#") [] [addrPrimTy, intPrimTy] (floatX16PrimTy) +primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX8#") [] [addrPrimTy, intPrimTy] (doubleX8PrimTy) +primOpInfo (VecReadScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int8X16PrimTy])) +primOpInfo (VecReadScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int16X8PrimTy])) +primOpInfo (VecReadScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int32X4PrimTy])) +primOpInfo (VecReadScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X2#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int64X2PrimTy])) +primOpInfo (VecReadScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X32#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int8X32PrimTy])) +primOpInfo (VecReadScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int16X16PrimTy])) +primOpInfo (VecReadScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int32X8PrimTy])) +primOpInfo (VecReadScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int64X4PrimTy])) +primOpInfo (VecReadScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X64#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int8X64PrimTy])) +primOpInfo (VecReadScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X32#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int16X32PrimTy])) +primOpInfo (VecReadScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int32X16PrimTy])) +primOpInfo (VecReadScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, int64X8PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word8X16PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word16X8PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word32X4PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X2#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word64X2PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X32#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word8X32PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word16X16PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word32X8PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word64X4PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X64#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word8X64PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X32#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word16X32PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word32X16PrimTy])) +primOpInfo (VecReadScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, word64X8PrimTy])) +primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, floatX4PrimTy])) +primOpInfo (VecReadScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX2#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, doubleX2PrimTy])) +primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, floatX8PrimTy])) +primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX4#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, doubleX4PrimTy])) +primOpInfo (VecReadScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX16#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, floatX16PrimTy])) +primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX8#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy deltaTy, doubleX8PrimTy])) +primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X16#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X8#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X4#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X2#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X32#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X16#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X8#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X4#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X64#") [deltaTyVar] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X32#") [deltaTyVar] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X16#") [deltaTyVar] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X8#") [deltaTyVar] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X16#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X8#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X4#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X2#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X32#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X16#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X8#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X4#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X64#") [deltaTyVar] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X32#") [deltaTyVar] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X16#") [deltaTyVar] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X8#") [deltaTyVar] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX4#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX2#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX8#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX4#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX16#") [deltaTyVar] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX8#") [deltaTyVar] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchByteArrayOp3 = mkGenPrimOp (fsLit "prefetchByteArray3#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchMutableByteArrayOp3 = mkGenPrimOp (fsLit "prefetchMutableByteArray3#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchAddrOp3 = mkGenPrimOp (fsLit "prefetchAddr3#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchValueOp3 = mkGenPrimOp (fsLit "prefetchValue3#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchByteArrayOp2 = mkGenPrimOp (fsLit "prefetchByteArray2#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchMutableByteArrayOp2 = mkGenPrimOp (fsLit "prefetchMutableByteArray2#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchAddrOp2 = mkGenPrimOp (fsLit "prefetchAddr2#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchValueOp2 = mkGenPrimOp (fsLit "prefetchValue2#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchByteArrayOp1 = mkGenPrimOp (fsLit "prefetchByteArray1#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchMutableByteArrayOp1 = mkGenPrimOp (fsLit "prefetchMutableByteArray1#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchAddrOp1 = mkGenPrimOp (fsLit "prefetchAddr1#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchValueOp1 = mkGenPrimOp (fsLit "prefetchValue1#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchByteArrayOp0 = mkGenPrimOp (fsLit "prefetchByteArray0#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchMutableByteArrayOp0 = mkGenPrimOp (fsLit "prefetchMutableByteArray0#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchAddrOp0 = mkGenPrimOp (fsLit "prefetchAddr0#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) +primOpInfo PrefetchValueOp0 = mkGenPrimOp (fsLit "prefetchValue0#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) + +#ifdef mingw32_HOST_OS +primOpInfo AsyncReadOp = mkGenPrimOp (fsLit "asyncRead#") [] [intPrimTy, intPrimTy, intPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, intPrimTy, intPrimTy])) +primOpInfo AsyncWriteOp = mkGenPrimOp (fsLit "asyncWrite#") [] [intPrimTy, intPrimTy, intPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, intPrimTy, intPrimTy])) +primOpInfo AsyncDoProcOp = mkGenPrimOp (fsLit "asyncDoProc#") [] [addrPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy UnboxedTuple [mkStatePrimTy realWorldTy, intPrimTy, intPrimTy])) +#endif diff --git a/include/primop-stricts-710.hs b/include/primop-stricts-710.hs new file mode 100644 --- /dev/null +++ b/include/primop-stricts-710.hs @@ -0,0 +1,16 @@ +primOpStrictness CatchOp = \ _arity -> mkClosedStrictSig [apply1Dmd,apply2Dmd,topDmd] topRes +primOpStrictness RaiseOp = \ _arity -> mkClosedStrictSig [topDmd] botRes +primOpStrictness RaiseIOOp = \ _arity -> mkClosedStrictSig [topDmd, topDmd] botRes +primOpStrictness MaskAsyncExceptionsOp = \ _arity -> mkClosedStrictSig [apply1Dmd,topDmd] topRes +primOpStrictness MaskUninterruptibleOp = \ _arity -> mkClosedStrictSig [apply1Dmd,topDmd] topRes +primOpStrictness UnmaskAsyncExceptionsOp = \ _arity -> mkClosedStrictSig [apply1Dmd,topDmd] topRes +primOpStrictness AtomicallyOp = \ _arity -> mkClosedStrictSig [apply1Dmd,topDmd] topRes +primOpStrictness RetryOp = \ _arity -> mkClosedStrictSig [topDmd] botRes +primOpStrictness CatchRetryOp = \ _arity -> mkClosedStrictSig [apply1Dmd,apply1Dmd,topDmd] topRes +primOpStrictness CatchSTMOp = \ _arity -> mkClosedStrictSig [apply1Dmd,apply2Dmd,topDmd] topRes +primOpStrictness DataToTagOp = \ _arity -> mkClosedStrictSig [evalDmd] topRes +primOpStrictness PrefetchValueOp3 = \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes +primOpStrictness PrefetchValueOp2 = \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes +primOpStrictness PrefetchValueOp1 = \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes +primOpStrictness PrefetchValueOp0 = \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes +primOpStrictness _ = \ arity -> mkClosedStrictSig (replicate arity topDmd) topRes diff --git a/lib/Foreign.js b/lib/Foreign.js --- a/lib/Foreign.js +++ b/lib/Foreign.js @@ -22,8 +22,6 @@ var __app4 = function(f,a,b,c,d) {return f(a,b,c,d);} var __app5 = function(f,a,b,c,d,e) {return f(a,b,c,d,e);} var __jsNull = function() {return null;} -var __jsTrue = function() {return true;} -var __jsFalse = function() {return false;} var __eq = function(a,b) {return a===b;} var __createJSFunc = function(arity, f){ if(f instanceof Function && arity === f.length) { diff --git a/lib/array.js b/lib/array.js --- a/lib/array.js +++ b/lib/array.js @@ -1,9 +1,9 @@ // Functions for dealing with arrays. function newArr(n, x) { - var arr = []; - for(; n >= 0; --n) { - arr.push(x); + var arr = new Array(n); + for(var i = 0; i < n; ++i) { + arr[i] = x; } return arr; } diff --git a/lib/floatdecode.js b/lib/floatdecode.js --- a/lib/floatdecode.js +++ b/lib/floatdecode.js @@ -5,6 +5,9 @@ var rts_scratchDouble = new Float64Array(rts_scratchBuf); function decodeFloat(x) { + if(x === 0) { + return [0,1,0,0,0]; + } rts_scratchFloat[0] = x; var sign = x < 0 ? -1 : 1; var exp = ((rts_scratchW32[0] >> 23) & 0xff) - 150; @@ -18,6 +21,11 @@ } function decodeDouble(x) { + if(x === 0) { + // GHC 7.10+ *really* doesn't like 0 to be represented as anything + // but zeroes all the way. + return [0,1,0,0,0]; + } rts_scratchDouble[0] = x; var sign = x < 0 ? -1 : 1; var manHigh = rts_scratchW32[1] & 0xfffff; diff --git a/lib/md5.js b/lib/md5.js --- a/lib/md5.js +++ b/lib/md5.js @@ -1,5 +1,5 @@ -// Joseph Myers' MD5 implementation; used under the BSD license. - +// Joseph Myers' MD5 implementation, ported to work on typed arrays. +// Used under the BSD license. function md5cycle(x, k) { var a = x[0], b = x[1], c = x[2], d = x[3]; @@ -99,22 +99,24 @@ return cmn(c ^ (b | (~d)), a, b, x, s, t); } -function md51(s) { - var n = s.length, +function md51(s, n) { + var a = s['v']['w8']; + var orig_n = n, state = [1732584193, -271733879, -1732584194, 271733878], i; - for (i=64; i<=s.length; i+=64) { - md5cycle(state, md5blk(s.substring(i-64, i))); + for (i=64; i<=n; i+=64) { + md5cycle(state, md5blk(a.subarray(i-64, i))); } - s = s.substring(i-64); + a = a.subarray(i-64); + n = n < (i-64) ? 0 : n-(i-64); var tail = [0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0]; - for (i=0; i>2] |= s.charCodeAt(i) << ((i%4) << 3); + for (i=0; i>2] |= a[i] << ((i%4) << 3); tail[i>>2] |= 0x80 << ((i%4) << 3); if (i > 55) { md5cycle(state, tail); for (i=0; i<16; i++) tail[i] = 0; } - tail[14] = n*8; + tail[14] = orig_n*8; md5cycle(state, tail); return state; } @@ -123,10 +125,10 @@ function md5blk(s) { var md5blks = [], i; for (i=0; i<64; i+=4) { - md5blks[i>>2] = s.charCodeAt(i) - + (s.charCodeAt(i+1) << 8) - + (s.charCodeAt(i+2) << 16) - + (s.charCodeAt(i+3) << 24); + md5blks[i>>2] = s[i] + + (s[i+1] << 8) + + (s[i+2] << 16) + + (s[i+3] << 24); } return md5blks; } @@ -148,10 +150,26 @@ return x.join(''); } -function md5(s) { - return hex(md51(s)); +function md5(s, n) { + return hex(md51(s, n)); } +window['md5'] = md5; + function add32(a, b) { return (a + b) & 0xFFFFFFFF; +} + +function __hsbase_MD5Init(ctx) {} +// Note that this is a one time "update", since that's all that's used by +// GHC.Fingerprint. +function __hsbase_MD5Update(ctx, s, n) { + ctx.md5 = md51(s, n); +} +function __hsbase_MD5Final(out, ctx) { + var a = out['v']['i32']; + a[0] = ctx.md5[0]; + a[1] = ctx.md5[1]; + a[2] = ctx.md5[2]; + a[3] = ctx.md5[3]; } diff --git a/lib/rts.js b/lib/rts.js --- a/lib/rts.js +++ b/lib/rts.js @@ -81,12 +81,12 @@ function E(t) { if(t instanceof T) { if(t.f !== __blackhole) { - var f = t.f; - t.f = __blackhole; if(t.x === __updatable) { + var f = t.f; + t.f = __blackhole; t.x = f(); } else { - return f(); + return t.f(); } } return t.x; @@ -303,7 +303,7 @@ } var __word_encodeFloat = __word_encodeDouble; -var jsRound = Math.round; +var jsRound = Math.round, rintDouble = jsRound, rintFloat = jsRound; var jsTrunc = Math.trunc ? Math.trunc : function(x) { return x < 0 ? Math.ceil(x) : Math.floor(x); }; @@ -313,6 +313,10 @@ var realWorld = undefined; if(typeof _ == 'undefined') { var _ = undefined; +} + +function popCnt64(i) { + return popCnt(I_getBits(i,0)) + popCnt(I_getBits(i,1)); } function popCnt(i) { diff --git a/libraries/haste-lib/src/Haste.hs b/libraries/haste-lib/src/Haste.hs --- a/libraries/haste-lib/src/Haste.hs +++ b/libraries/haste-lib/src/Haste.hs @@ -8,13 +8,13 @@ module Haste ( JSString, JSAny, URL, alert, prompt, eval, writeLog, catJSStr, fromJSStr, - module Haste.JSType, module Haste.DOM.Core, module Haste.Timer, + module Haste.Prim.JSType, module Haste.DOM.Core, module Haste.Timer, module Haste.Random, module Haste.Hash ) where import Haste.Prim import Haste.Timer import Haste.Random -import Haste.JSType +import Haste.Prim.JSType import Haste.DOM.Core import Haste.Hash import Control.Monad.IO.Class diff --git a/libraries/haste-lib/src/Haste/Ajax.hs b/libraries/haste-lib/src/Haste/Ajax.hs --- a/libraries/haste-lib/src/Haste/Ajax.hs +++ b/libraries/haste-lib/src/Haste/Ajax.hs @@ -4,7 +4,7 @@ -- | Low level XMLHttpRequest support. IE6 and older are not supported. module Haste.Ajax (Method (..), URL, ajaxRequest, noParams) where import Haste.Prim -import Haste.JSType +import Haste.Prim.JSType import Control.Monad.IO.Class #ifdef __HASTE__ diff --git a/libraries/haste-lib/src/Haste/Any.hs b/libraries/haste-lib/src/Haste/Any.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Any.hs +++ /dev/null @@ -1,350 +0,0 @@ --- For the FFI -{-# LANGUAGE ForeignFunctionInterface, PatternGuards, CPP, BangPatterns #-} - --- For generic default instances -{-# LANGUAGE TypeOperators, ScopedTypeVariables, FlexibleInstances, - FlexibleContexts, OverloadedStrings, DefaultSignatures, - OverlappingInstances #-} - --- For less annoying instances -{-# LANGUAGE TupleSections #-} - --- | Converting to/from JS-native data. -module Haste.Any ( - ToAny (..), FromAny (..), Generic, JSAny (..), - Opaque, toOpaque, fromOpaque, - nullValue, toObject, has, get, index - ) where -import GHC.Generics -import Haste.Prim -import Haste.JSType -import Data.Int -import Data.Word -import Unsafe.Coerce -import Control.Applicative - -#ifdef __HASTE__ -foreign import ccall __lst2arr :: Ptr [a] -> JSAny -foreign import ccall __arr2lst :: Int -> JSAny -> Ptr [a] -foreign import ccall "String" jsString :: JSAny -> JSString -foreign import ccall "Number" jsNumber :: JSAny -> Double -foreign import ccall "__jsNull" jsNull :: JSAny -foreign import ccall "__jsTrue" jsTrue :: JSAny -foreign import ccall "__jsFalse" jsFalse :: JSAny -foreign import ccall __new :: IO JSAny -foreign import ccall __set :: JSAny -> JSString -> JSAny -> IO () -foreign import ccall __get :: JSAny -> JSString -> IO JSAny -foreign import ccall __has :: JSAny -> JSString -> IO Bool -#else -__new :: IO JSAny -__new = return undefined -__get :: JSAny -> JSString -> IO JSAny -__get _ _ = return undefined -__set :: JSAny -> JSString -> JSAny -> IO () -__set _ _ _ = return () -__has :: JSAny -> JSString -> IO Bool -__has _ _ = return False -__lst2arr :: Ptr [a] -> JSAny -__lst2arr _ = undefined -__arr2lst :: Int -> JSAny -> Ptr [a] -__arr2lst _ _ = undefined -jsString :: JSAny -> JSString -jsString _ = undefined -jsNumber :: JSAny -> Double -jsNumber _ = undefined -jsNull, jsTrue, jsFalse :: JSAny -jsNull = undefined -jsTrue = undefined -jsFalse = undefined -#endif -{- - For theoretical purposes, imagine the following here: - foreign import ccall __intToAny :: Int -> JSAny - ... - In practice, however, we use unsafeCoerce for that to avoid the roundtrip. --} - --- | The JS value null. -nullValue :: JSAny -nullValue = jsNull - --- | Build a new JS object from a list of key:value pairs. -toObject :: [(JSString, JSAny)] -> JSAny -toObject ps = veryUnsafePerformIO $ do - o <- __new - mapM_ (uncurry $ __set o) ps - return o - --- | Read a member from a JS object. Throws an error if the member can not be --- marshalled into a value of type @a@. -{-# INLINE get #-} -get :: FromAny a => JSAny -> JSString -> IO a -get o k = __get o k >>= fromAny - -{-# INLINE index #-} --- | Read an element from a JS array. Throws an error if the member can not be --- marshalled into a value of type @a@. -index :: FromAny a => JSAny -> Int -> IO a -index o k = __get o (unsafeCoerce k) >>= fromAny - --- | Check if a JS object has a particular member. -{-# INLINE has #-} -has :: JSAny -> JSString -> IO Bool -has = __has - --- | Any type that can be converted into a JavaScript value. -class ToAny a where - -- | Build a JS object from a Haskell value. - -- The default instance creates an object from any type that derives - -- 'Generic' according to the following rules: - -- * Records turn into plain JS objects, with record names as field names. - -- * Non-record product types turn into objects containing a @$data@ field - -- which contains all of the constructor's unnamed fields. - -- * Values of enum types turn into strings matching their constructors. - -- * Non-enum types with more than one constructor gain an extra field, - -- @$tag@, which contains the name of the constructor used to create the - -- object. - toAny :: a -> JSAny - default toAny :: (GToAny (Rep a), Generic a) => a -> JSAny - toAny x = - case gToAny False g of - Tree x' -> toObject x' - One x' -> if isEnum g then x' else toAny [x'] - List x' -> toAny x' - where g = from x - - listToAny :: [a] -> JSAny - listToAny = __lst2arr . toPtr . map toAny - --- | Any type that can be converted from a JavaScript value. -class FromAny a where - -- | Convert a value from JS with a reasonable conversion if an exact match - -- is not possible. Examples of reasonable conversions would be truncating - -- floating point numbers to integers, or turning signed integers into - -- unsigned. - fromAny :: JSAny -> IO a - - listFromAny :: JSAny -> IO [a] - listFromAny = mapM fromAny . fromPtr . __arr2lst 0 - --- | The Opaque type is inhabited by values that can be passed to JavaScript --- using their raw Haskell representation. Opaque values are completely --- useless to JS code, and should not be inspected. This is useful for, --- for instance, storing data in some JS-native data structure for later --- retrieval. -newtype Opaque a = Opaque {fromOpaque :: a} - -toOpaque :: a -> Opaque a -toOpaque = Opaque - - - --- ToAny instances -instance ToAny JSAny where toAny = unsafeCoerce -instance ToAny (Ptr a) where toAny = unsafeCoerce -instance ToAny JSString where toAny = unsafeCoerce -instance ToAny Int where toAny = unsafeCoerce -instance ToAny Int8 where toAny = unsafeCoerce -instance ToAny Int16 where toAny = unsafeCoerce -instance ToAny Int32 where toAny = unsafeCoerce -instance ToAny Word where toAny = unsafeCoerce -instance ToAny Word8 where toAny = unsafeCoerce -instance ToAny Word16 where toAny = unsafeCoerce -instance ToAny Word32 where toAny = unsafeCoerce -instance ToAny Float where toAny = unsafeCoerce -instance ToAny Double where toAny = unsafeCoerce -instance ToAny Char where - toAny = unsafeCoerce - listToAny = toAny . toJSStr -instance ToAny () where - toAny _ = jsNull -instance ToAny (Opaque a) where - toAny (Opaque x) = unsafeCoerce $ toPtr x -instance ToAny Bool where - toAny True = jsTrue - toAny False = jsFalse - --- | Lists are marshalled into arrays, with the exception of 'String'. -instance ToAny a => ToAny [a] where - toAny = listToAny - --- | Maybe is simply a nullable type. Nothing is equivalent to null, and any --- non-null value is equivalent to x in Just x. -instance ToAny a => ToAny (Maybe a) where - toAny Nothing = jsNull - toAny (Just x) = toAny x - --- | Tuples are marshalled into arrays. -instance (ToAny a, ToAny b) => ToAny (a, b) where - toAny (a, b) = toAny [toAny a, toAny b] - -instance (ToAny a, ToAny b, ToAny c) => ToAny (a, b, c) where - toAny (a, b, c) = toAny [toAny a, toAny b, toAny c] - -instance (ToAny a, ToAny b, ToAny c, ToAny d) => - ToAny (a, b, c, d) where - toAny (a, b, c, d) = toAny [toAny a, toAny b, toAny c, toAny d] - -instance (ToAny a, ToAny b, ToAny c, ToAny d, ToAny e) => - ToAny (a, b, c, d, e) where - toAny (a, b, c, d, e) = toAny [toAny a,toAny b,toAny c,toAny d,toAny e] - -instance (ToAny a, ToAny b, ToAny c, ToAny d, ToAny e, - ToAny f) => ToAny (a, b, c, d, e, f) where - toAny (a, b, c, d, e, f) = - toAny [toAny a, toAny b, toAny c, toAny d, toAny e, toAny f] - -instance (ToAny a, ToAny b, ToAny c, ToAny d, ToAny e, - ToAny f, ToAny g) => ToAny (a, b, c, d, e, f, g) where - toAny (a, b, c, d, e, f, g) = - toAny [toAny a,toAny b,toAny c,toAny d,toAny e,toAny f,toAny g] - - - -instance FromAny JSAny where - fromAny x = return (unsafeCoerce x) -instance FromAny (Ptr a) where - fromAny x = return (unsafeCoerce x) -instance FromAny JSString where - fromAny x = return (jsString x) -instance FromAny Int where - fromAny x = return (convert (jsNumber x)) -instance FromAny Int8 where - fromAny x = return (convert (jsNumber x)) -instance FromAny Int16 where - fromAny x = return (convert (jsNumber x)) -instance FromAny Int32 where - fromAny x = return (convert (jsNumber x)) -instance FromAny Word where - fromAny x = return (convert (jsNumber x)) -instance FromAny Word8 where - fromAny x = return (convert (jsNumber x)) -instance FromAny Word16 where - fromAny x = return (convert (jsNumber x)) -instance FromAny Word32 where - fromAny x = return (convert (jsNumber x)) -instance FromAny Float where - fromAny x = return (unsafeCoerce (jsNumber x)) -instance FromAny Double where - fromAny x = return (jsNumber x) -instance FromAny Char where - fromAny x = return (unsafeCoerce (jsNumber x)) - listFromAny x = fromJSStr <$> fromAny x -instance FromAny () where - fromAny _ = return () -instance FromAny (Opaque a) where - fromAny x = Opaque . fromPtr <$> fromAny x -instance FromAny Bool where - fromAny x | x == jsTrue = return True - | otherwise = return False - -instance FromAny a => FromAny [a] where - fromAny = listFromAny - -instance FromAny a => FromAny (Maybe a) where - fromAny x | x == jsNull = return Nothing - | otherwise = Just <$> fromAny x - -instance (FromAny a, FromAny b) => FromAny (a, b) where - fromAny x = do - [a,b] <- fromAny x - (,) <$> fromAny a <*> fromAny b - -instance (FromAny a, FromAny b, FromAny c) => FromAny (a, b, c) where - fromAny x = do - [a,b,c] <- fromAny x - (,,) <$> fromAny a <*> fromAny b <*> fromAny c - -instance (FromAny a, FromAny b, FromAny c, FromAny d) => - FromAny (a, b, c, d) where - fromAny x = do - [a,b,c,d] <- fromAny x - (,,,) <$> fromAny a <*> fromAny b <*> fromAny c <*> fromAny d - -instance (FromAny a, FromAny b, FromAny c, FromAny d, FromAny e) => - FromAny (a, b, c, d, e) where - fromAny x = do - [a,b,c,d,e] <- fromAny x - (,,,,) <$> fromAny a <*> fromAny b <*> fromAny c - <*> fromAny d <*> fromAny e - -instance (FromAny a, FromAny b, FromAny c, FromAny d, FromAny e, FromAny f) => - FromAny (a, b, c, d, e, f) where - fromAny x = do - [a,b,c,d,e,f] <- fromAny x - (,,,,,) <$> fromAny a <*> fromAny b <*> fromAny c - <*> fromAny d <*> fromAny e <*> fromAny f - -instance (FromAny a, FromAny b, FromAny c, FromAny d, - FromAny e, FromAny f, FromAny g) => - FromAny (a, b, c, d, e, f, g) where - fromAny x = do - [a,b,c,d,e,f,g] <- fromAny x - (,,,,,,) <$> fromAny a <*> fromAny b <*> fromAny c <*> fromAny d - <*> fromAny e <*> fromAny f <*> fromAny g - -data Value = One !JSAny | List ![JSAny] | Tree ![(JSString, JSAny)] - --- Generic instances -class GToAny f where - gToAny :: Bool -> f a -> Value - isEnum :: f a -> Bool - -instance GToAny U1 where - gToAny _ U1 = error "U1: unpossible!" - isEnum _ = True - -instance ToAny a => GToAny (K1 i a) where - gToAny _ (K1 x) = One (toAny x) - isEnum _ = False - -instance (Selector c, GToAny a) => GToAny (M1 S c a) where - gToAny mcs (M1 x) = do - case name of - "" -> One value - _ -> Tree [(name, value)] - where name = toJSStr (selName (undefined :: M1 S c a ())) - value = - case gToAny mcs x of - Tree x' -> toObject x' - One x' -> toAny x' - List x' -> toAny x' - isEnum _ = isEnum (undefined :: a ()) - -instance Constructor c => GToAny (M1 C c U1) where - gToAny _ _ = One (toAny $ conName (undefined :: M1 C c U1 ())) - isEnum _ = True - -instance (Constructor c, GToAny a) => GToAny (M1 C c a) where - gToAny many_constrs (M1 x) - | many_constrs = - case args of - Tree args' -> Tree (("$tag", toAny tag) : args') - One arg -> Tree [("$tag", toAny tag), ("$data", arg)] - List args' -> Tree [("$tag", toAny tag), ("$data", toAny args')] - | otherwise = - args - where - tag = conName (undefined :: M1 C c a ()) - args = gToAny many_constrs x - isEnum _ = isEnum (undefined :: a ()) - -instance GToAny a => GToAny (M1 D c a) where - gToAny cs (M1 x) = gToAny cs x - isEnum _ = isEnum (undefined :: a ()) - -instance (GToAny a, GToAny b) => GToAny (a :*: b) where - gToAny cs (a :*: b) = - case (gToAny cs a, gToAny cs b) of - (One l, One r) -> List [l, r] - (One x, List xs) -> List (x:xs) - (List xs, One x) -> List (xs ++ [x]) - (List l, List r) -> List (l ++ r) - (Tree l, Tree r) -> Tree (l ++ r) - (_, _) -> error "Tree :*: non-tree!" - isEnum _ = False - -instance (GToAny a, GToAny b) => GToAny (a :+: b) where - gToAny _ (L1 x) = gToAny True x - gToAny _ (R1 x) = gToAny True x - isEnum _ = isEnum (undefined :: a ()) && isEnum (undefined :: b ()) diff --git a/libraries/haste-lib/src/Haste/App.hs b/libraries/haste-lib/src/Haste/App.hs --- a/libraries/haste-lib/src/Haste/App.hs +++ b/libraries/haste-lib/src/Haste/App.hs @@ -9,13 +9,13 @@ Sessions, SessionID, liftServerIO, forkServerIO, remote, runApp, (<.>), getSessionID, getActiveSessions, onSessionEnd, - AppCfg, cfgHost, cfgPort, mkConfig, + AppCfg, defaultConfig, cfgHost, cfgPort, mkConfig, Client, runClient, onServer, liftIO, JSString, JSAny, URL, alert, prompt, eval, writeLog, catJSStr, fromJSStr, module Haste.DOM.Core, module Haste.Random, - module Haste.JSType, + module Haste.Prim.JSType, module Haste.Hash, module Haste.Binary ) where @@ -24,7 +24,7 @@ import Haste.Binary (Binary (..)) import Haste.DOM.Core import Haste.Random -import Haste.JSType +import Haste.Prim.JSType import Haste.Hash import Haste import Control.Monad.IO.Class diff --git a/libraries/haste-lib/src/Haste/Audio.hs b/libraries/haste-lib/src/Haste/Audio.hs --- a/libraries/haste-lib/src/Haste/Audio.hs +++ b/libraries/haste-lib/src/Haste/Audio.hs @@ -16,7 +16,7 @@ import Haste.Audio.Events as Events import Haste.DOM.JSString import Haste.Foreign -import Haste.JSType +import Haste.Prim.JSType import Haste.Prim #if __GLASGOW_HASKELL__ < 710 import Control.Applicative diff --git a/libraries/haste-lib/src/Haste/Concurrent/Ajax.hs b/libraries/haste-lib/src/Haste/Concurrent/Ajax.hs --- a/libraries/haste-lib/src/Haste/Concurrent/Ajax.hs +++ b/libraries/haste-lib/src/Haste/Concurrent/Ajax.hs @@ -6,7 +6,7 @@ ) where import Haste.Concurrent.Monad import Haste.Ajax -import Haste.JSType +import Haste.Prim.JSType -- | Make a blocking AJAX request in the CIO monad. -- Note that unlike using the browser's native blocking AJAX facilities, diff --git a/libraries/haste-lib/src/Haste/DOM.hs b/libraries/haste-lib/src/Haste/DOM.hs --- a/libraries/haste-lib/src/Haste/DOM.hs +++ b/libraries/haste-lib/src/Haste/DOM.hs @@ -1,9 +1,14 @@ {-# LANGUAGE GADTs #-} -- | DOM manipulation functions using 'String' for string representation. module Haste.DOM ( - module Core, - IsElem (..), Elem, PropID, ElemID, QuerySelector, ElemClass, - AttrName, AttrValue, + -- From Haste.DOM.Core + AttrName (..), Attribute, IsElem (..), Elem, + attribute, set, with, children, + click, focus, blur, document, documentBody, appendChild, addChild, + addChildBefore, insertChildBefore, getFirstChild, getLastChild, getChildren, + setChildren, clearChildren, deleteChild, removeChild, + -- Own exports + PropID, ElemID, QuerySelector, ElemClass, AttrValue, style, attr, (=:), newElem, newTextElem, elemById, elemsByQS, elemsByClass, @@ -14,8 +19,6 @@ setClass, toggleClass, hasClass ) where import qualified Haste.DOM.JSString as J -import qualified Haste.DOM.Core as Core - hiding (Elem (..), AttrName (..)) import Haste.DOM.Core import Haste.Prim (fromJSStr, toJSStr) import Control.Monad.IO.Class diff --git a/libraries/haste-lib/src/Haste/DOM/JSString.hs b/libraries/haste-lib/src/Haste/DOM/JSString.hs --- a/libraries/haste-lib/src/Haste/DOM/JSString.hs +++ b/libraries/haste-lib/src/Haste/DOM/JSString.hs @@ -1,9 +1,14 @@ {-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, CPP #-} -- | DOM manipulation functions using 'JSString' for string representation. module Haste.DOM.JSString ( - module Core, - IsElem (..), Elem, PropID, ElemID, QuerySelector, ElemClass, - AttrName, AttrValue, + -- From Haste.DOM.Core + AttrName (..), Attribute, IsElem (..), Elem, + attribute, set, with, children, + click, focus, blur, document, documentBody, appendChild, addChild, + addChildBefore, insertChildBefore, getFirstChild, getLastChild, getChildren, + setChildren, clearChildren, deleteChild, removeChild, + -- Own exports + PropID, ElemID, QuerySelector, ElemClass, AttrValue, style, attr, (=:), newElem, newTextElem, elemById, elemsByQS, elemsByClass, @@ -14,9 +19,7 @@ setClass, toggleClass, hasClass ) where import Haste.Prim -import Haste.JSType -import qualified Haste.DOM.Core as Core - hiding (Elem (..), AttrName (..)) +import Haste.Prim.JSType import Haste.DOM.Core import Data.Maybe (isNothing, fromJust) import Control.Monad.IO.Class diff --git a/libraries/haste-lib/src/Haste/Events/KeyEvents.hs b/libraries/haste-lib/src/Haste/Events/KeyEvents.hs --- a/libraries/haste-lib/src/Haste/Events/KeyEvents.hs +++ b/libraries/haste-lib/src/Haste/Events/KeyEvents.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings, TypeFamilies, CPP #-} -- | Events relating to mouse keyboard input. module Haste.Events.KeyEvents (KeyEvent (..), KeyData (..), mkKeyData) where -import Haste.Any +import Haste.Prim.Any import Haste.Events.Core #if __GLASGOW_HASKELL__ < 710 import Control.Applicative diff --git a/libraries/haste-lib/src/Haste/Foreign.hs b/libraries/haste-lib/src/Haste/Foreign.hs --- a/libraries/haste-lib/src/Haste/Foreign.hs +++ b/libraries/haste-lib/src/Haste/Foreign.hs @@ -1,159 +1,16 @@ -{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, BangPatterns, CPP #-} -{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -#if __GLASGOW_HASKELL__ < 710 -{-# LANGUAGE OverlappingInstances #-} -#endif --- | High level interface for interfacing with JavaScript. +{-# LANGUAGE CPP #-} +-- | High level JavaScript foreign interface. module Haste.Foreign ( - module Haste.Any, + -- * Conversion to/from JSAny + ToAny (..), FromAny (..), JSAny, + Opaque, toOpaque, fromOpaque, + nullValue, toObject, has, get, index, + + -- * Importing and exporting JavaScript functions FFI, JSFunc, ffi, constant, export - ) where -import Haste.Prim -import Haste.Any - --- | A JS function. -type JSFun = JSAny - -#ifdef __HASTE__ -foreign import ccall "eval" __eval :: JSString -> JSFun -foreign import ccall __apply :: JSFun -> Ptr [JSAny] -> IO JSAny -foreign import ccall __app0 :: JSFun -> IO JSAny -foreign import ccall __app1 :: JSFun -> JSAny -> IO JSAny -foreign import ccall __app2 :: JSFun -> JSAny -> JSAny -> IO JSAny -foreign import ccall __app3 :: JSFun -> JSAny -> JSAny -> JSAny -> IO JSAny -foreign import ccall __app4 :: JSFun - -> JSAny -> JSAny -> JSAny -> JSAny -> IO JSAny -foreign import ccall __app5 :: JSFun - -> JSAny -> JSAny -> JSAny -> JSAny -> JSAny - -> IO JSAny -foreign import ccall __createJSFunc :: Int -> JSAny -> IO JSAny -#else -__eval :: JSString -> JSFun -__eval _ = undefined -__apply :: JSFun -> Ptr [JSAny] -> IO JSAny -__apply _ _ = return undefined -__app0 :: JSFun -> IO JSAny -__app0 _ = return undefined -__app1 :: JSFun -> JSAny -> IO JSAny -__app1 _ _ = return undefined -__app2 :: JSFun -> JSAny -> JSAny -> IO JSAny -__app2 _ _ _ = return undefined -__app3 :: JSFun -> JSAny -> JSAny -> JSAny -> IO JSAny -__app3 _ _ _ _ = return undefined -__app4 :: JSFun -> JSAny -> JSAny -> JSAny -> JSAny -> IO JSAny -__app4 _ _ _ _ _ = return undefined -__app5 :: JSFun -> JSAny -> JSAny -> JSAny -> JSAny -> JSAny -> IO JSAny -__app5 _ _ _ _ _ _ = return undefined -__createJSFunc :: Int -> JSAny -> IO JSAny -__createJSFunc _ = return undefined -#endif - --- | Any type that can be imported from JavaScript. This means any type which --- has an instance of 'FromAny', and any function where all argument types --- has 'ToAny' instances and the return type is in the IO monad and has a --- 'FromAny' instance. -class FFI a where - __ffi :: JSFun -> [JSAny] -> a - -instance FromAny a => FFI (IO a) where - {-# INLINE __ffi #-} - __ffi = ffiio - -instance (ToAny a, FFI b) => FFI (a -> b) where - {-# INLINE __ffi #-} - __ffi f !as !a = __ffi f (a' : as) - where !a' = toAny a - -{-# INLINE [0] ffiio #-} --- | Apply the result of an FFI call. -ffiio :: FromAny a => JSFun -> [JSAny] -> IO a -ffiio !f !as = __apply f (toPtr as) >>= fromAny - -{-# INLINE ffi #-} --- | Creates a Haskell function from the given string of JavaScript code. If --- this code is not well typed or is otherwise incorrect, your program may --- crash or misbehave in mystifying ways. Haste makes a best-effort try to --- save you from poorly typed JS here, but there are no guarantees. --- --- For instance, the following WILL cause crazy behavior due to wrong types: --- @ffi "(function(x) {return x+1;})" :: Int -> Int -> IO Int@ --- --- In other words, this function is as unsafe as the JS it calls on. You --- have been warned. --- --- The imported JS is evaluated lazily, unless (a) it is a function object --- in which case evaluation order does not affect the semantics of the --- imported code, or if (b) the imported code is explicitly marked as strict: --- --- someFunction = ffi "__strict(someJSFunction)" --- --- Literals which depends on some third party initialization, the existence --- of a DOM tree or some other condition which is not fulfilled at load time --- should *not* be marked strict. -ffi :: FFI a => JSString -> a -ffi s = __ffi f [] - where - {-# NOINLINE f #-} - f = __eval s - --- | Create a Haskell value from a constant JS expression. -constant :: FromAny a => JSString -> a -constant = veryUnsafePerformIO . fromAny . __eval - --- Don't build intermediate list for functions of <= 5 arguments. -{-# RULES -"app0" [1] forall f. ffiio f [] = __app0 f >>= fromAny -"app1" [1] forall f a. ffiio f [a] = __app1 f a >>= fromAny -"app2" [1] forall f a b. ffiio f [b,a] = __app2 f a b >>= fromAny -"app3" [1] forall f a b c. ffiio f [c,b,a] = __app3 f a b c >>= fromAny -"app4" [1] forall f a b c d. ffiio f [d,c,b,a] = __app4 f a b c d >>= fromAny -"app5" [1] forall f a b c d e. ffiio f [e,d,c,b,a] = - __app5 f a b c d e >>= fromAny - #-} - --- | Export a symbol. That symbol may then be accessed from JavaScript through --- Haste.name() as a normal function. Remember, however, that if you are --- using --with-js to include your JS, in conjunction with --- --opt-minify or any option that implies it, you will instead need --- to access your exports through Haste[\'name\'](), or Closure will mangle --- your function names. -{-# INLINE export #-} -export :: ToAny a => JSString -> a -> IO () -export = ffi "(function(s,f){Haste[s] = f;})" - -type family JS a where - JS (a -> b) = JSAny -> JS b - JS (IO a) = IO JSAny - JS a = JSAny - -class JSFunc a where - mkJSFunc :: a -> JS a - arity :: a -> Int - -instance (ToAny a, JS a ~ JSAny) => JSFunc a where - mkJSFunc = toAny - arity _ = 0 - -instance ToAny a => JSFunc (IO a) where - mkJSFunc = fmap toAny - arity _ = 1 - -instance (FromAny a, JSFunc b) => JSFunc (a -> b) where - mkJSFunc f = mkJSFunc . f . veryUnsafePerformIO . fromAny - arity f = 1 + arity (f undefined) - -instance (FromAny a, JSFunc b) => ToAny (a -> b) where - toAny f = - veryUnsafePerformIO . __createJSFunc (arity f) . toAny . toOpaque $ mkJSFunc f - -instance ToAny a => ToAny (IO a) where - toAny = veryUnsafePerformIO . __createJSFunc 0 . toAny . toOpaque . mkJSFunc - -#if __GLASGOW_HASKELL__ < 710 -instance FFI a => FromAny a where -#else -instance {-# OVERLAPPABLE #-} FFI a => FromAny a where +#if __GLASGOW_HASKELL__ >= 710 + , safe_ffi, StaticPtr #endif - fromAny f = return $ __ffi f [] + ) where +import Haste.Prim.Foreign diff --git a/libraries/haste-lib/src/Haste/JSON.hs b/libraries/haste-lib/src/Haste/JSON.hs --- a/libraries/haste-lib/src/Haste/JSON.hs +++ b/libraries/haste-lib/src/Haste/JSON.hs @@ -31,7 +31,6 @@ jsJSONParse :: JSString -> JSAny jsJSONParse = unsafePerformIO . go where - {-# NOINLINE go #-} go :: JSString -> IO JSAny go = ffi "(function(s){return JSON.parse(s);})" #else diff --git a/libraries/haste-lib/src/Haste/JSType.hs b/libraries/haste-lib/src/Haste/JSType.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/JSType.hs +++ /dev/null @@ -1,293 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, ForeignFunctionInterface, MagicHash, - TypeSynonymInstances, FlexibleInstances, EmptyDataDecls, - UnliftedFFITypes, UndecidableInstances, CPP, OverloadedStrings #-} --- | Efficient conversions to and from JS native types. -module Haste.JSType ( - JSType (..), JSNum (..), toString, fromString, convert - ) where -import GHC.Int -import GHC.Word -import Haste.Prim (JSString (..), toJSStr, fromJSStr) -#ifdef __HASTE__ -import Haste.Prim (JSAny (..)) -import GHC.Prim -import GHC.Integer.GMP.Internals -import GHC.Types (Int (..)) -#else -import Data.Char -import GHC.Float -#endif - --- | Any type which can be converted to/from a 'JSString'. -class JSType a where - toJSString :: a -> JSString - fromJSString :: JSString -> Maybe a - --- | (Almost) all numeric types can be efficiently converted to and from --- Double, which is the internal representation for most of them. -class JSNum a where - toNumber :: a -> Double - fromNumber :: Double -> a - -instance JSType JSString where - toJSString = id - fromJSString = Just - -#ifdef __HASTE__ - -foreign import ccall "Number" jsNumber :: JSString -> Double -foreign import ccall "String" jsString :: Double -> JSString -foreign import ccall jsTrunc :: Double -> Int -foreign import ccall jsTruncW :: Double -> Int -foreign import ccall "I_toInt" jsIToInt :: ByteArray# -> Int -foreign import ccall "I_toString" jsIToString :: ByteArray# -> JSString -foreign import ccall "I_fromString" jsStringToI :: JSString -> ByteArray# -foreign import ccall "I_fromNumber" jsNumToI :: ByteArray# -> ByteArray# - -unsafeToJSString :: a -> JSString -unsafeToJSString = unsafeCoerce# jsString - -unsafeIntFromJSString :: JSString -> Maybe a -unsafeIntFromJSString s = - case jsNumber s of - d | isNaN d -> Nothing - | otherwise -> Just (unsafeCoerce# (jsTrunc d)) - -unsafeWordFromJSString :: JSString -> Maybe a -unsafeWordFromJSString s = - case jsNumber s of - d | isNaN d -> Nothing - | otherwise -> Just (unsafeCoerce# (jsTruncW d)) - --- JSNum instances - -instance JSNum Char where - fromNumber = unsafeCoerce# jsTrunc - toNumber = unsafeCoerce# - -instance JSNum Int where - fromNumber = unsafeCoerce# jsTrunc - toNumber = unsafeCoerce# - -instance JSNum Int8 where - fromNumber n = case fromNumber n of I# n' -> I8# (narrow8Int# n') - toNumber = unsafeCoerce# - -instance JSNum Int16 where - fromNumber n = case fromNumber n of I# n' -> I16# (narrow16Int# n') - toNumber = unsafeCoerce# - -instance JSNum Int32 where - fromNumber = unsafeCoerce# jsTrunc - toNumber = unsafeCoerce# - -instance JSNum Word where - fromNumber n = - case jsTrunc (unsafeCoerce# n) of - I# n' -> W# (int2Word# n') - toNumber = unsafeCoerce# - -instance JSNum Word8 where - fromNumber w = case fromNumber w of W# w' -> W8# (narrow8Word# w') - toNumber = unsafeCoerce# - -instance JSNum Word16 where - fromNumber w = case fromNumber w of W# w' -> W16# (narrow16Word# w') - toNumber = unsafeCoerce# - -instance JSNum Word32 where - fromNumber w = case fromNumber w of W# w' -> W32# w' - toNumber = unsafeCoerce# - -instance JSNum Integer where - toNumber (S# n) = toNumber (I# n) - toNumber (J# n) = unsafeCoerce# (jsIToInt n) - fromNumber n = J# (jsNumToI (unsafeCoerce# n)) - -instance JSNum Float where - fromNumber = unsafeCoerce# - toNumber = unsafeCoerce# - -instance JSNum Double where - fromNumber = id - toNumber = id - --- JSType instances -instance JSType Bool where - toJSString True = "true" - toJSString _ = "false" - fromJSString "true" = Just True - fromJSString "false" = Just False - fromJSString _ = Nothing -instance JSType Int where - toJSString = unsafeToJSString - fromJSString = unsafeIntFromJSString -instance JSType Int8 where - toJSString = unsafeToJSString - fromJSString = unsafeIntFromJSString -instance JSType Int16 where - toJSString = unsafeToJSString - fromJSString = unsafeIntFromJSString -instance JSType Int32 where - toJSString = unsafeToJSString - fromJSString = unsafeIntFromJSString -instance JSType Word where - toJSString = unsafeToJSString - fromJSString = unsafeWordFromJSString -instance JSType Word8 where - toJSString = unsafeToJSString - fromJSString = unsafeWordFromJSString -instance JSType Word16 where - toJSString = unsafeToJSString - fromJSString = unsafeWordFromJSString -instance JSType Word32 where - toJSString = unsafeToJSString - fromJSString = unsafeWordFromJSString - -instance JSType Float where - fromJSString s = - case jsNumber s of - d | isNaN d -> Nothing - | otherwise -> Just (unsafeCoerce# d) - toJSString = unsafeToJSString - -instance JSType Double where - fromJSString s = - case jsNumber s of - d | isNaN d -> Nothing - | otherwise -> Just d - toJSString = unsafeToJSString - --- This is completely insane, but GHC for some reason pukes when we try to --- use the constructors of the actual integers, so we coerce them into this --- isomorphic type to work with them instead. -data Dummy = Small Int# | Big ByteArray# - -instance JSType Integer where - toJSString n = - case unsafeCoerce# n of - Small n' -> toJSString (I# n') - Big n' -> jsIToString n' - fromJSString s = - case jsStringToI s of - n -> Just (unsafeCoerce# (Big n)) - -instance JSType String where - toJSString = toJSStr - fromJSString = Just . fromJSStr - -instance JSType () where - toJSString _ = toJSStr "()" - fromJSString s | s == toJSStr "()" = Just () - | otherwise = Nothing - -#else - -instance JSNum Char where - toNumber = fromIntegral . ord - fromNumber = chr . round - -instance JSNum Int where - toNumber = fromIntegral - fromNumber = round -instance JSNum Int8 where - toNumber = fromIntegral - fromNumber = round -instance JSNum Int16 where - toNumber = fromIntegral - fromNumber = round -instance JSNum Int32 where - toNumber = fromIntegral - fromNumber = round - -instance JSNum Word where - toNumber = fromIntegral - fromNumber = round -instance JSNum Word8 where - toNumber = fromIntegral - fromNumber = round -instance JSNum Word16 where - toNumber = fromIntegral - fromNumber = round -instance JSNum Word32 where - toNumber = fromIntegral - fromNumber = round - -instance JSNum Double where - toNumber = id - fromNumber = id -instance JSNum Float where - toNumber = float2Double - fromNumber = double2Float - -instance JSNum Integer where - toNumber = fromInteger - fromNumber = round - -mread :: Read a => String -> Maybe a -mread s = - case reads s of - [(x, "")] -> x - _ -> Nothing - -instance JSType Int where - toJSString = toJSStr . show - fromJSString = mread . fromJSStr -instance JSType Int8 where - toJSString = toJSStr . show - fromJSString = mread . fromJSStr -instance JSType Int16 where - toJSString = toJSStr . show - fromJSString = mread . fromJSStr -instance JSType Int32 where - toJSString = toJSStr . show - fromJSString = mread . fromJSStr - -instance JSType Word where - toJSString = toJSStr . show - fromJSString = mread . fromJSStr -instance JSType Word8 where - toJSString = toJSStr . show - fromJSString = mread . fromJSStr -instance JSType Word16 where - toJSString = toJSStr . show - fromJSString = mread . fromJSStr -instance JSType Word32 where - toJSString = toJSStr . show - fromJSString = mread . fromJSStr - -instance JSType Double where - toJSString = toJSStr . show - fromJSString = mread . fromJSStr -instance JSType Float where - toJSString = toJSStr . show - fromJSString = mread . fromJSStr - -instance JSType Integer where - toJSString = toJSStr . show - fromJSString = mread . fromJSStr - -instance JSType Bool where - toJSString = toJSStr . show - fromJSString = mread . fromJSStr - -instance JSType () where - toJSString = toJSStr . show - fromJSString = mread . fromJSStr - -instance JSType String where - toJSString = toJSStr - fromJSString = Just . fromJSStr - -#endif - --- Derived functions - -toString :: JSType a => a -> String -toString = fromJSStr . toJSString - -fromString :: JSType a => String -> Maybe a -fromString = fromJSString . toJSStr - -convert :: (JSNum a, JSNum b) => a -> b -convert = fromNumber . toNumber diff --git a/libraries/haste-lib/src/Haste/Prim.hs b/libraries/haste-lib/src/Haste/Prim.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Prim.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface, MagicHash, - TypeSynonymInstances, FlexibleInstances, CPP, UnboxedTuples #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Haste.Prim (JSString (..), URL, toJSStr, fromJSStr, catJSStr, JSAny (..), - Ptr, toPtr, fromPtr, veryUnsafePerformIO) where -import Foreign.Ptr -import Data.String -#ifdef __HASTE__ -import Unsafe.Coerce -import GHC.CString -import qualified GHC.HastePrim as HP -#else -import Data.List (intercalate) -#endif -import GHC.Prim -import GHC.Types (IO (..)) - -type URL = String - --- | Any JS value, with one layer of indirection. -newtype JSAny = JSAny (Ptr Any) - -instance Eq JSAny where - (==) = __eq - -{-# INLINE veryUnsafePerformIO #-} --- | Strict, inlineable, dupable version of 'unsafePerformIO'. Only use if you --- are extremely sure this is not a problem. So please don't. -veryUnsafePerformIO :: IO a -> a -veryUnsafePerformIO (IO act) = - case act realWorld# of - (# _, x #) -> x - --- | Concatenate a series of JSStrings using the specified separator. -catJSStr :: JSString -> [JSString] -> JSString -#ifdef __HASTE__ -foreign import ccall jsCat :: Ptr [JSString] -> JSString -> JSString -foreign import ccall __eq :: JSAny -> JSAny -> Bool -catJSStr sep strs = jsCat (toPtr strs) sep -#else -catJSStr sep strs = toJSStr $ intercalate (fromJSStr sep) (map fromJSStr strs) -__eq :: JSAny -> JSAny -> Bool -__eq _ _ = undefined -#endif - -#ifdef __HASTE__ -foreign import ccall strEq :: JSString -> JSString -> Bool -foreign import ccall strOrd :: JSString -> JSString -> Ptr Ordering - --- | Native JavaScript strings. -newtype JSString = JSString JSAny - -instance Eq JSString where - (==) = strEq - -instance Ord JSString where - compare a b = fromPtr (strOrd a b) - -instance Show JSString where - show = fromJSStr - --- | In normal Haskell, we use Storable for data that can be pointed to. When --- we compile to JS, however, anything can be "pointed" to and nothing needs --- to be stored. -toPtr :: a -> Ptr a -toPtr = unsafeCoerce - --- | Unwrap a "pointer" to something. -fromPtr :: Ptr a -> a -fromPtr = unsafeCoerce - -{-# RULES "toJSS/fromJSS" forall s. toJSStr (fromJSStr s) = s #-} -{-# RULES "fromJSS/toJSS" forall s. fromJSStr (toJSStr s) = s #-} -{-# RULES "toJSS/unCSTR" forall s. toJSStr (unpackCString# s) = - JSString (JSAny (toPtr (unsafeCoerce# s))) #-} -{-# RULES "toJSS/unCSTRU8" forall s. toJSStr (unpackCStringUtf8# s) = - JSString (JSAny (toPtr (unsafeCoerce# s))) #-} - --- | Convert a 'String' to a 'JSString'. -{-# NOINLINE [1] toJSStr #-} -toJSStr :: String -> JSString -toJSStr = unsafeCoerce# HP.toJSStr - -instance IsString JSString where - fromString = toJSStr - --- | Convert a 'JSString' to a 'String'. -{-# NOINLINE [1] fromJSStr #-} -fromJSStr :: JSString -> String -fromJSStr = unsafeCoerce# HP.fromJSStr - -#else - --- | JSStrings are represented as normal strings server-side; should probably --- be changed to ByteString or Text. -newtype JSString = JSString String - -instance IsString JSString where - fromString = JSString - -instance Eq JSString where - (JSString a) == (JSString b) = a == b - -instance Ord JSString where - (JSString a) `compare` (JSString b) = a `compare` b - -instance Show JSString where - show = fromJSStr - -toJSStr :: String -> JSString -toJSStr = JSString - -fromJSStr :: JSString -> String -fromJSStr (JSString s) = s - -toPtr :: a -> Ptr a -toPtr = error "toPtr used in native code!" - -fromPtr :: Ptr a -> a -fromPtr = error "fromPtr used in native code!" - -#endif diff --git a/libraries/haste-lib/src/Haste/Random.hs b/libraries/haste-lib/src/Haste/Random.hs --- a/libraries/haste-lib/src/Haste/Random.hs +++ b/libraries/haste-lib/src/Haste/Random.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, CPP, OverloadedStrings #-} module Haste.Random (Random (..), Seed, next, mkSeed, newSeed) where -import Haste.JSType +import Haste.Prim.JSType import Data.Int import Data.Word import Data.List (unfoldr) @@ -16,19 +16,15 @@ newtype Seed = Seed JSAny deriving (ToAny, FromAny) -{-# NOINLINE nxt #-} nxt :: Seed -> IO Seed nxt = ffi "(function(s){return window['md51'](s.join(','));})" -{-# NOINLINE getN #-} getN :: Seed -> IO Int getN = ffi "(function(s){return s[0];})" -{-# NOINLINE toSeed #-} toSeed :: Int -> IO Seed toSeed = ffi "(function(n){return window['md51'](n.toString());})" -{-# NOINLINE createSeed #-} createSeed :: IO Seed createSeed = ffi "(function(){return window['md51'](jsRand().toString());})" #else diff --git a/libraries/haste-prim/src/Haste/Prim.hs b/libraries/haste-prim/src/Haste/Prim.hs new file mode 100644 --- /dev/null +++ b/libraries/haste-prim/src/Haste/Prim.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface, MagicHash, + TypeSynonymInstances, FlexibleInstances, CPP, UnboxedTuples #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Haste.Prim ( + JSString (..), URL, toJSStr, fromJSStr, catJSStr, JSAny (..), + Ptr, toPtr, fromPtr, veryUnsafePerformIO) where +import Foreign.Ptr +import Data.String +#ifdef __HASTE__ +import Unsafe.Coerce +import GHC.CString +import qualified GHC.HastePrim as HP +#else +import Data.List (intercalate) +#endif +import GHC.Prim +import GHC.Types (IO (..)) + +type URL = String + +-- | Any JS value, with one layer of indirection. +newtype JSAny = JSAny (Ptr Any) + +instance Eq JSAny where + (==) = __eq + +{-# INLINE veryUnsafePerformIO #-} +-- | Strict, inlineable, dupable version of 'unsafePerformIO'. Only use if you +-- are extremely sure this is not a problem. So please don't. +veryUnsafePerformIO :: IO a -> a +veryUnsafePerformIO (IO act) = + case act realWorld# of + (# _, x #) -> x + +-- | Concatenate a series of JSStrings using the specified separator. +catJSStr :: JSString -> [JSString] -> JSString +#ifdef __HASTE__ +foreign import ccall jsCat :: Ptr [JSString] -> JSString -> JSString +foreign import ccall __eq :: JSAny -> JSAny -> Bool +catJSStr sep strs = jsCat (toPtr strs) sep +#else +catJSStr sep strs = toJSStr $ intercalate (fromJSStr sep) (map fromJSStr strs) +__eq :: JSAny -> JSAny -> Bool +__eq _ _ = undefined +#endif + +#ifdef __HASTE__ +foreign import ccall strEq :: JSString -> JSString -> Bool +foreign import ccall strOrd :: JSString -> JSString -> Ptr Ordering + +-- | Native JavaScript strings. +newtype JSString = JSString JSAny + +instance Eq JSString where + (==) = strEq + +instance Ord JSString where + compare a b = fromPtr (strOrd a b) + +instance Show JSString where + show = fromJSStr + +-- | In normal Haskell, we use Storable for data that can be pointed to. When +-- we compile to JS, however, anything can be "pointed" to and nothing needs +-- to be stored. +toPtr :: a -> Ptr a +toPtr = unsafeCoerce + +-- | Unwrap a "pointer" to something. +fromPtr :: Ptr a -> a +fromPtr = unsafeCoerce + +{-# RULES "toJSS/fromJSS" forall s. toJSStr (fromJSStr s) = s #-} +{-# RULES "fromJSS/toJSS" forall s. fromJSStr (toJSStr s) = s #-} +{-# RULES "toJSS/unCSTR" forall s. toJSStr (unpackCString# s) = + JSString (JSAny (toPtr (unsafeCoerce# s))) #-} +{-# RULES "toJSS/unCSTRU8" forall s. toJSStr (unpackCStringUtf8# s) = + JSString (JSAny (toPtr (unsafeCoerce# s))) #-} + +-- | Convert a 'String' to a 'JSString'. +{-# NOINLINE [1] toJSStr #-} +toJSStr :: String -> JSString +toJSStr = unsafeCoerce# HP.toJSStr + +instance IsString JSString where + fromString = toJSStr + +-- | Convert a 'JSString' to a 'String'. +{-# NOINLINE [1] fromJSStr #-} +fromJSStr :: JSString -> String +fromJSStr = unsafeCoerce# HP.fromJSStr + +#else + +-- | JSStrings are represented as normal strings server-side; should probably +-- be changed to ByteString or Text. +newtype JSString = JSString String + +instance IsString JSString where + fromString = JSString + +instance Eq JSString where + (JSString a) == (JSString b) = a == b + +instance Ord JSString where + (JSString a) `compare` (JSString b) = a `compare` b + +instance Show JSString where + show = fromJSStr + +toJSStr :: String -> JSString +toJSStr = JSString + +fromJSStr :: JSString -> String +fromJSStr (JSString s) = s + +toPtr :: a -> Ptr a +toPtr = error "toPtr used in native code!" + +fromPtr :: Ptr a -> a +fromPtr = error "fromPtr used in native code!" + +#endif diff --git a/libraries/haste-prim/src/Haste/Prim/Any.hs b/libraries/haste-prim/src/Haste/Prim/Any.hs new file mode 100644 --- /dev/null +++ b/libraries/haste-prim/src/Haste/Prim/Any.hs @@ -0,0 +1,468 @@ +-- For the FFI +{-# LANGUAGE ForeignFunctionInterface, PatternGuards, CPP, BangPatterns #-} + +-- For generic default instances +{-# LANGUAGE TypeOperators, ScopedTypeVariables, FlexibleInstances, + FlexibleContexts, OverloadedStrings, DefaultSignatures #-} + +#if __GLASGOW_HASKELL__ < 710 +{-# LANGUAGE OverlappingInstances #-} +#endif + +-- For less annoying instances +{-# LANGUAGE TupleSections #-} + +-- | Converting to/from JS-native data. +module Haste.Prim.Any ( + ToAny (..), FromAny (..), Generic, JSAny (..), + Opaque, toOpaque, fromOpaque, + nullValue, toObject, has, get, index + ) where +import GHC.Generics +import Control.Exception +import Haste.Prim +import Haste.Prim.JSType +import Data.Int +import Data.Word +import Unsafe.Coerce +import System.IO.Unsafe -- for toObject +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +#endif + +#ifdef __HASTE__ +foreign import ccall __lst2arr :: Ptr [a] -> JSAny +foreign import ccall __arr2lst :: Int -> JSAny -> Ptr [a] +foreign import ccall "String" jsString :: JSAny -> JSString +foreign import ccall "Number" jsNumber :: JSAny -> Double +foreign import ccall __jsNull :: IO JSAny +foreign import ccall __new :: IO JSAny +foreign import ccall __set :: JSAny -> JSString -> JSAny -> IO () +foreign import ccall __get :: JSAny -> JSString -> IO JSAny +foreign import ccall __has :: JSAny -> JSString -> IO Bool +#else +__new :: IO JSAny +__new = return undefined +__get :: JSAny -> JSString -> IO JSAny +__get _ _ = return undefined +__set :: JSAny -> JSString -> JSAny -> IO () +__set _ _ _ = return () +__has :: JSAny -> JSString -> IO Bool +__has _ _ = return False +__lst2arr :: Ptr [a] -> JSAny +__lst2arr _ = undefined +__arr2lst :: Int -> JSAny -> Ptr [a] +__arr2lst _ _ = undefined +jsString :: JSAny -> JSString +jsString _ = undefined +jsNumber :: JSAny -> Double +jsNumber _ = undefined +__jsNull :: IO JSAny +__jsNull = undefined +#endif + +{-# NOINLINE jsNull #-} +jsNull :: JSAny +jsNull = unsafePerformIO __jsNull + +{- + For theoretical purposes, imagine the following here: + foreign import ccall __intToAny :: Int -> JSAny + ... + In practice, however, we use unsafeCoerce for that to avoid the roundtrip. +-} + +-- | The JS value null. +nullValue :: JSAny +nullValue = jsNull + +-- | Build a new JS object from a list of key:value pairs. +toObject :: [(JSString, JSAny)] -> JSAny +toObject ps = veryUnsafePerformIO $ do + o <- __new + mapM_ (uncurry $ __set o) ps + return o + +-- | Read a member from a JS object. Throws an error if the member can not be +-- marshalled into a value of type @a@. +{-# INLINE get #-} +get :: FromAny a => JSAny -> JSString -> IO a +get o k = __get o k >>= fromAny + +{-# INLINE index #-} +-- | Read an element from a JS array. Throws an error if the member can not be +-- marshalled into a value of type @a@. +index :: FromAny a => JSAny -> Int -> IO a +index o k = __get o (unsafeCoerce k) >>= fromAny + +-- | Check if a JS object has a particular member. +{-# INLINE has #-} +has :: JSAny -> JSString -> IO Bool +has = __has + +-- | Any type that can be converted into a JavaScript value. +class ToAny a where + -- | Build a JS object from a Haskell value. + -- The default instance creates an object from any type that derives + -- 'Generic' according to the following rules: + -- * Records turn into plain JS objects, with record names as field names. + -- * Non-record product types turn into objects containing a @$data@ field + -- which contains all of the constructor's unnamed fields. + -- * Values of enum types turn into strings matching their constructors. + -- * Non-enum types with more than one constructor gain an extra field, + -- @$tag@, which contains the name of the constructor used to create the + -- object. + toAny :: a -> JSAny + default toAny :: (GToAny (Rep a), Generic a) => a -> JSAny + toAny x = + case gToAny False g of + Tree x' -> toObject x' + One x' -> if isEnum g then x' else toAny [x'] + List x' -> toAny x' + where g = from x + + listToAny :: [a] -> JSAny + listToAny = __lst2arr . toPtr . map toAny + +-- | Any type that can be converted from a JavaScript value. +class FromAny a where + -- | Convert a value from JS with a reasonable conversion if an exact match + -- is not possible. Examples of reasonable conversions would be truncating + -- floating point numbers to integers, or turning signed integers into + -- unsigned. + fromAny :: JSAny -> IO a + default fromAny :: (GToAny (Rep a), GFromAny (Rep a), Generic a) + => JSAny -> IO a + fromAny x = to <$> gFromAny False x + + listFromAny :: JSAny -> IO [a] + listFromAny = mapM fromAny . fromPtr . __arr2lst 0 + +-- | The Opaque type is inhabited by values that can be passed to JavaScript +-- using their raw Haskell representation. Opaque values are completely +-- useless to JS code, and should not be inspected. This is useful for, +-- for instance, storing data in some JS-native data structure for later +-- retrieval. +newtype Opaque a = Opaque {fromOpaque :: a} + +toOpaque :: a -> Opaque a +toOpaque = Opaque + + + +-- ToAny instances +instance ToAny JSAny where toAny = unsafeCoerce +instance ToAny (Ptr a) where toAny = unsafeCoerce +instance ToAny JSString where toAny = unsafeCoerce +instance ToAny Int where toAny = unsafeCoerce +instance ToAny Int8 where toAny = unsafeCoerce +instance ToAny Int16 where toAny = unsafeCoerce +instance ToAny Int32 where toAny = unsafeCoerce +instance ToAny Word where toAny = unsafeCoerce +instance ToAny Word8 where toAny = unsafeCoerce +instance ToAny Word16 where toAny = unsafeCoerce +instance ToAny Word32 where toAny = unsafeCoerce +instance ToAny Float where toAny = unsafeCoerce +instance ToAny Double where toAny = unsafeCoerce +instance ToAny Char where + toAny = unsafeCoerce + listToAny = toAny . toJSStr +instance ToAny () where + toAny _ = jsNull +instance ToAny (Opaque a) where + toAny (Opaque x) = unsafeCoerce $ toPtr x +instance ToAny Bool where + toAny = unsafeCoerce + +-- | Lists are marshalled into arrays, with the exception of 'String'. +instance ToAny a => ToAny [a] where + toAny = listToAny + +-- | Maybe is simply a nullable type. Nothing is equivalent to null, and any +-- non-null value is equivalent to x in Just x. +instance ToAny a => ToAny (Maybe a) where + toAny Nothing = jsNull + toAny (Just x) = toAny x + +-- | Tuples are marshalled into arrays. +instance (ToAny a, ToAny b) => ToAny (a, b) where + toAny (a, b) = toAny [toAny a, toAny b] + +instance (ToAny a, ToAny b, ToAny c) => ToAny (a, b, c) where + toAny (a, b, c) = toAny [toAny a, toAny b, toAny c] + +instance (ToAny a, ToAny b, ToAny c, ToAny d) => + ToAny (a, b, c, d) where + toAny (a, b, c, d) = toAny [toAny a, toAny b, toAny c, toAny d] + +instance (ToAny a, ToAny b, ToAny c, ToAny d, ToAny e) => + ToAny (a, b, c, d, e) where + toAny (a, b, c, d, e) = toAny [toAny a,toAny b,toAny c,toAny d,toAny e] + +instance (ToAny a, ToAny b, ToAny c, ToAny d, ToAny e, + ToAny f) => ToAny (a, b, c, d, e, f) where + toAny (a, b, c, d, e, f) = + toAny [toAny a, toAny b, toAny c, toAny d, toAny e, toAny f] + +instance (ToAny a, ToAny b, ToAny c, ToAny d, ToAny e, + ToAny f, ToAny g) => ToAny (a, b, c, d, e, f, g) where + toAny (a, b, c, d, e, f, g) = + toAny [toAny a,toAny b,toAny c,toAny d,toAny e,toAny f,toAny g] + + + +instance FromAny JSAny where + fromAny x = return (unsafeCoerce x) +instance FromAny (Ptr a) where + fromAny x = return (unsafeCoerce x) +instance FromAny JSString where + fromAny x = return (jsString x) +instance FromAny Int where + fromAny x = return (convert (jsNumber x)) +instance FromAny Int8 where + fromAny x = return (convert (jsNumber x)) +instance FromAny Int16 where + fromAny x = return (convert (jsNumber x)) +instance FromAny Int32 where + fromAny x = return (convert (jsNumber x)) +instance FromAny Word where + fromAny x = return (convert (jsNumber x)) +instance FromAny Word8 where + fromAny x = return (convert (jsNumber x)) +instance FromAny Word16 where + fromAny x = return (convert (jsNumber x)) +instance FromAny Word32 where + fromAny x = return (convert (jsNumber x)) + +-- unsafeCoerce for Float and Double saves a lot on performance, and only +-- differs in semantics if the value in question is a) not a number, and +-- b) passed verbatim back into JS land +instance FromAny Float where + fromAny x = unsafeCoerce x +instance FromAny Double where + fromAny x = unsafeCoerce x + +instance FromAny Char where + fromAny x = return (unsafeCoerce (jsNumber x)) + listFromAny x = fromJSStr <$> fromAny x +instance FromAny () where + fromAny _ = return () +instance FromAny (Opaque a) where + fromAny x = Opaque . fromPtr <$> fromAny x +instance FromAny Bool where + fromAny = return . unsafeCoerce + +instance FromAny a => FromAny [a] where + fromAny = listFromAny + +instance FromAny a => FromAny (Maybe a) where + fromAny x | x == jsNull = return Nothing + | otherwise = Just <$> fromAny x + +instance (FromAny a, FromAny b) => FromAny (a, b) where + fromAny x = do + [a,b] <- fromAny x + (,) <$> fromAny a <*> fromAny b + +instance (FromAny a, FromAny b, FromAny c) => FromAny (a, b, c) where + fromAny x = do + [a,b,c] <- fromAny x + (,,) <$> fromAny a <*> fromAny b <*> fromAny c + +instance (FromAny a, FromAny b, FromAny c, FromAny d) => + FromAny (a, b, c, d) where + fromAny x = do + [a,b,c,d] <- fromAny x + (,,,) <$> fromAny a <*> fromAny b <*> fromAny c <*> fromAny d + +instance (FromAny a, FromAny b, FromAny c, FromAny d, FromAny e) => + FromAny (a, b, c, d, e) where + fromAny x = do + [a,b,c,d,e] <- fromAny x + (,,,,) <$> fromAny a <*> fromAny b <*> fromAny c + <*> fromAny d <*> fromAny e + +instance (FromAny a, FromAny b, FromAny c, FromAny d, FromAny e, FromAny f) => + FromAny (a, b, c, d, e, f) where + fromAny x = do + [a,b,c,d,e,f] <- fromAny x + (,,,,,) <$> fromAny a <*> fromAny b <*> fromAny c + <*> fromAny d <*> fromAny e <*> fromAny f + +instance (FromAny a, FromAny b, FromAny c, FromAny d, + FromAny e, FromAny f, FromAny g) => + FromAny (a, b, c, d, e, f, g) where + fromAny x = do + [a,b,c,d,e,f,g] <- fromAny x + (,,,,,,) <$> fromAny a <*> fromAny b <*> fromAny c <*> fromAny d + <*> fromAny e <*> fromAny f <*> fromAny g + +data Value = One !JSAny | List ![JSAny] | Tree ![(JSString, JSAny)] + +-- GToAny instances +class GToAny f where + gToAny :: Bool -> f a -> Value + isEnum :: f a -> Bool + +instance GToAny U1 where + gToAny _ U1 = error "U1: unpossible!" + isEnum _ = True + +instance ToAny a => GToAny (K1 i a) where + gToAny _ (K1 x) = One (toAny x) + isEnum _ = False + +instance (Selector c, GToAny a) => GToAny (M1 S c a) where + gToAny mcs (M1 x) = do + case name of + "" -> One value + _ -> Tree [(name, value)] + where name = toJSStr (selName (undefined :: M1 S c a ())) + value = + case gToAny mcs x of + Tree x' -> toObject x' + One x' -> toAny x' + List x' -> toAny x' + isEnum _ = isEnum (undefined :: a ()) + +instance Constructor c => GToAny (M1 C c U1) where + gToAny _ _ = One (toAny $ conName (undefined :: M1 C c U1 ())) + isEnum _ = True + +#if __GLASGOW_HASKELL__ < 710 +instance (Constructor c, GToAny a) => GToAny (M1 C c a) where +#else +instance {-# OVERLAPPABLE #-} (Constructor c, GToAny a) => + GToAny (M1 C c a) where +#endif + gToAny many_constrs (M1 x) + | many_constrs = + case args of + Tree args' -> Tree (("$tag", toAny tag) : args') + One arg -> Tree [("$tag", toAny tag), ("$data", arg)] + List args' -> Tree [("$tag", toAny tag), ("$data", toAny args')] + | otherwise = + args + where + tag = conName (undefined :: M1 C c a ()) + args = gToAny many_constrs x + isEnum _ = isEnum (undefined :: a ()) + +instance GToAny a => GToAny (M1 D c a) where + gToAny cs (M1 x) = gToAny cs x + isEnum _ = isEnum (undefined :: a ()) + +instance (GToAny a, GToAny b) => GToAny (a :*: b) where + gToAny cs (a :*: b) = + case (gToAny cs a, gToAny cs b) of + (One l, One r) -> List [l, r] + (One x, List xs) -> List (x:xs) + (List xs, One x) -> List (xs ++ [x]) + (List l, List r) -> List (l ++ r) + (Tree l, Tree r) -> Tree (l ++ r) + (_, _) -> error "Tree :*: non-tree!" + isEnum _ = False + +instance (GToAny a, GToAny b) => GToAny (a :+: b) where + gToAny _ (L1 x) = gToAny True x + gToAny _ (R1 x) = gToAny True x + isEnum _ = isEnum (undefined :: a ()) && isEnum (undefined :: b ()) + + + + + +-- GFromAny instances +class GFromAny f where + gFromAny :: Bool -> JSAny -> IO (f a) + isRecord :: f a -> Bool + gFromList :: Int -> JSAny -> IO (f a, Int) + gFromList = error "gFromList called on non-product!" + +instance GFromAny U1 where + gFromAny _ _ = return U1 + isRecord _ = False + +instance (ToAny a, FromAny a) => GFromAny (K1 i a) where + gFromAny _ x = do + x' <- fromAny x + return $ K1 x' + isRecord _ = False + gFromList ix x = do + x' <- x `index` ix + return (K1 x', ix+1) + +instance (Selector c, GFromAny a) => GFromAny (M1 S c a) where + gFromAny mcs x = do + exists <- x `has` prop + if exists + then M1 <$> (get x prop >>= gFromAny mcs) + else error $ "No such member: '" ++ sn ++ "'" + where + sn = selName (undefined :: M1 S c a ()) + prop = toJSStr sn + isRecord _ = not (null $ selName (undefined :: M1 S c a ())) + gFromList ix x = do + (x', ix') <- gFromList ix x + return (M1 x', ix') + +instance Constructor c => GFromAny (M1 C c U1) where + gFromAny _ x = do + n <- fromAny x + if (n == cn) + then return $ M1 U1 + else error $ "Couldn't fromAny constructor: expected " ++ cn + ++ " but got " ++ n + where + cn = conName (undefined :: M1 C c U1 ()) + isRecord _ = False + +#if __GLASGOW_HASKELL__ < 710 +instance (Constructor c, GFromAny a) => GFromAny (M1 C c a) where +#else +instance {-# OVERLAPPABLE #-} (Constructor c, GFromAny a) => + GFromAny (M1 C c a) where +#endif + gFromAny many_constrs x + | many_constrs = do + t <- x `get` "$tag" + if t == tag + then M1 <$> (x `get` "$data" >>= gFromAny many_constrs) + else error $ "Couldn't fromAny constructor: expected " ++ tag + ++ " but got " ++ t + | isRecord (undefined :: a ()) = do + M1 <$> gFromAny many_constrs x + | otherwise = do + M1 . fst <$> gFromList 0 x + where + tag = conName (undefined :: M1 C c a ()) + isRecord _ = isRecord (undefined :: a ()) + +instance GFromAny a => GFromAny (M1 D c a) where + gFromAny cs x = M1 <$> gFromAny cs x + isRecord _ = isRecord (undefined :: a ()) + gFromList ix x = do + (x', ix') <- gFromList ix x + return (M1 x', ix') + +instance (GFromAny a, GFromAny b) => GFromAny (a :*: b) where + gFromAny cs x = do + a <- gFromAny cs x + b <- gFromAny cs x + return (a :*: b) + isRecord _ = isRecord (undefined :: a ()) + gFromList ix x = do + (a, ix') <- gFromList ix x + (b, ix'') <- gFromList ix' x + return (a :*: b, ix'') + +instance (GFromAny a, GFromAny b) => GFromAny (a :+: b) where + gFromAny _ x = do + catch (L1 <$> gFromAny True x) + (withSomeException $ R1 <$> gFromAny True x) + isRecord _ = isRecord (undefined :: a ()) || isRecord (undefined :: b ()) + +withSomeException :: IO a -> SomeException -> IO a +withSomeException m _ = m + +foreign import ccall "jsLog" dbg :: JSAny -> IO () diff --git a/libraries/haste-prim/src/Haste/Prim/Foreign.hs b/libraries/haste-prim/src/Haste/Prim/Foreign.hs new file mode 100644 --- /dev/null +++ b/libraries/haste-prim/src/Haste/Prim/Foreign.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, BangPatterns, CPP #-} +{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +#if __GLASGOW_HASKELL__ < 710 +{-# LANGUAGE OverlappingInstances #-} +#endif +-- | High level JavaScript foreign interface. +module Haste.Prim.Foreign ( + module Haste.Prim.Any, + FFI, JSFunc, + ffi, constant, export +#if __GLASGOW_HASKELL__ >= 710 + , safe_ffi, StaticPtr +#endif + ) where +import Haste.Prim +import Haste.Prim.Any +#if __GLASGOW_HASKELL__ >= 710 +import GHC.StaticPtr (StaticPtr, deRefStaticPtr) +#endif + +-- | A JS function. +type JSFun = JSAny + +#ifdef __HASTE__ +foreign import ccall "eval" __eval :: JSString -> JSFun +foreign import ccall __apply :: JSFun -> Ptr [JSAny] -> IO JSAny +foreign import ccall __app0 :: JSFun -> IO JSAny +foreign import ccall __app1 :: JSFun -> JSAny -> IO JSAny +foreign import ccall __app2 :: JSFun -> JSAny -> JSAny -> IO JSAny +foreign import ccall __app3 :: JSFun -> JSAny -> JSAny -> JSAny -> IO JSAny +foreign import ccall __app4 :: JSFun + -> JSAny -> JSAny -> JSAny -> JSAny -> IO JSAny +foreign import ccall __app5 :: JSFun + -> JSAny -> JSAny -> JSAny -> JSAny -> JSAny + -> IO JSAny +foreign import ccall __createJSFunc :: Int -> JSAny -> IO JSAny +#else +__eval :: JSString -> JSFun +__eval _ = undefined +__apply :: JSFun -> Ptr [JSAny] -> IO JSAny +__apply _ _ = return undefined +__app0 :: JSFun -> IO JSAny +__app0 _ = return undefined +__app1 :: JSFun -> JSAny -> IO JSAny +__app1 _ _ = return undefined +__app2 :: JSFun -> JSAny -> JSAny -> IO JSAny +__app2 _ _ _ = return undefined +__app3 :: JSFun -> JSAny -> JSAny -> JSAny -> IO JSAny +__app3 _ _ _ _ = return undefined +__app4 :: JSFun -> JSAny -> JSAny -> JSAny -> JSAny -> IO JSAny +__app4 _ _ _ _ _ = return undefined +__app5 :: JSFun -> JSAny -> JSAny -> JSAny -> JSAny -> JSAny -> IO JSAny +__app5 _ _ _ _ _ _ = return undefined +__createJSFunc :: Int -> JSAny -> IO JSAny +__createJSFunc _ = return undefined +#endif + +-- | Any type that can be imported from JavaScript. This means any type which +-- has an instance of 'FromAny', and any function where all argument types +-- has 'ToAny' instances and the return type is in the IO monad and has a +-- 'FromAny' instance. +class FFI a where + __ffi :: JSFun -> [JSAny] -> a + +instance FromAny a => FFI (IO a) where + {-# INLINE __ffi #-} + __ffi = ffiio + +instance (ToAny a, FFI b) => FFI (a -> b) where + {-# INLINE __ffi #-} + __ffi f !as !a = __ffi f (a' : as) + where !a' = toAny a + +{-# INLINE [0] ffiio #-} +-- | Apply the result of an FFI call. +ffiio :: FromAny a => JSFun -> [JSAny] -> IO a +ffiio !f !as = __apply f (toPtr as) >>= fromAny + +{-# INLINE ffi #-} +-- | Creates a Haskell function from the given string of JavaScript code. If +-- this code is not well typed or is otherwise incorrect, your program may +-- crash or misbehave in mystifying ways. Haste makes a best-effort try to +-- save you from poorly typed JS here, but there are no guarantees. +-- +-- For instance, the following WILL cause crazy behavior due to wrong types: +-- @ffi "(function(x) {return x+1;})" :: Int -> Int -> IO Int@ +-- +-- In other words, this function is as unsafe as the JS it calls on. You +-- have been warned. +-- +-- The imported JS is evaluated lazily, unless (a) it is a function object +-- in which case evaluation order does not affect the semantics of the +-- imported code, or if (b) the imported code is explicitly marked as strict: +-- +-- someFunction = ffi "__strict(someJSFunction)" +-- +-- Literals which depends on some third party initialization, the existence +-- of a DOM tree or some other condition which is not fulfilled at load time +-- should *not* be marked strict. +ffi :: FFI a => JSString -> a +ffi s = __ffi f [] + where + {-# NOINLINE f #-} + f = __eval s + +#if __GLASGOW_HASKELL__ >= 710 +safe_ffi :: FFI a => StaticPtr JSString -> a +safe_ffi = ffi . deRefStaticPtr +#endif + +-- | Create a Haskell value from a constant JS expression. +constant :: FromAny a => JSString -> a +constant = veryUnsafePerformIO . fromAny . __eval + +-- Don't build intermediate list for functions of <= 5 arguments. +{-# RULES +"app0" [1] forall f. ffiio f [] = __app0 f >>= fromAny +"app1" [1] forall f a. ffiio f [a] = __app1 f a >>= fromAny +"app2" [1] forall f a b. ffiio f [b,a] = __app2 f a b >>= fromAny +"app3" [1] forall f a b c. ffiio f [c,b,a] = __app3 f a b c >>= fromAny +"app4" [1] forall f a b c d. ffiio f [d,c,b,a] = __app4 f a b c d >>= fromAny +"app5" [1] forall f a b c d e. ffiio f [e,d,c,b,a] = + __app5 f a b c d e >>= fromAny + #-} + +-- | Export a symbol. That symbol may then be accessed from JavaScript through +-- Haste.name() as a normal function. Remember, however, that if you are +-- using --with-js to include your JS, in conjunction with +-- --opt-minify or any option that implies it, you will instead need +-- to access your exports through Haste[\'name\'](), or Closure will mangle +-- your function names. +{-# INLINE export #-} +export :: ToAny a => JSString -> a -> IO () +export = ffi "(function(s,f){Haste[s] = f;})" + +type family JS a where + JS (a -> b) = JSAny -> JS b + JS (IO a) = IO JSAny + JS a = JSAny + +class JSFunc a where + mkJSFunc :: a -> JS a + arity :: a -> Int + +#if __GLASGOW_HASKELL__ < 710 +instance (ToAny a, JS a ~ JSAny) => JSFunc a where +#else +instance {-# OVERLAPPABLE #-} (ToAny a, JS a ~ JSAny) => JSFunc a where +#endif + mkJSFunc = toAny + arity _ = 0 + +instance ToAny a => JSFunc (IO a) where + mkJSFunc = fmap toAny + arity _ = 1 + +instance (FromAny a, JSFunc b) => JSFunc (a -> b) where + mkJSFunc f = mkJSFunc . f . veryUnsafePerformIO . fromAny + arity f = 1 + arity (f undefined) + +instance (FromAny a, JSFunc b) => ToAny (a -> b) where + toAny f = + veryUnsafePerformIO . __createJSFunc (arity f) . toAny . toOpaque $ mkJSFunc f + +instance ToAny a => ToAny (IO a) where + toAny = veryUnsafePerformIO . __createJSFunc 0 . toAny . toOpaque . mkJSFunc + +#if __GLASGOW_HASKELL__ < 710 +instance FFI a => FromAny a where +#else +instance {-# OVERLAPPABLE #-} FFI a => FromAny a where +#endif + fromAny f = return $ __ffi f [] diff --git a/libraries/haste-prim/src/Haste/Prim/JSType.hs b/libraries/haste-prim/src/Haste/Prim/JSType.hs new file mode 100644 --- /dev/null +++ b/libraries/haste-prim/src/Haste/Prim/JSType.hs @@ -0,0 +1,293 @@ +{-# LANGUAGE MultiParamTypeClasses, ForeignFunctionInterface, MagicHash, + TypeSynonymInstances, FlexibleInstances, EmptyDataDecls, + UnliftedFFITypes, UndecidableInstances, CPP, OverloadedStrings #-} +-- | Efficient conversions to and from JS native types. +module Haste.Prim.JSType ( + JSType (..), JSNum (..), toString, fromString, convert + ) where +import GHC.Int +import GHC.Word +import Haste.Prim (JSString (..), toJSStr, fromJSStr) +#ifdef __HASTE__ +import Haste.Prim (JSAny (..)) +import GHC.Prim +import GHC.Integer.GMP.Internals +import GHC.Types (Int (..)) +#else +import Data.Char +import GHC.Float +#endif + +-- | Any type which can be converted to/from a 'JSString'. +class JSType a where + toJSString :: a -> JSString + fromJSString :: JSString -> Maybe a + +-- | (Almost) all numeric types can be efficiently converted to and from +-- Double, which is the internal representation for most of them. +class JSNum a where + toNumber :: a -> Double + fromNumber :: Double -> a + +instance JSType JSString where + toJSString = id + fromJSString = Just + +#ifdef __HASTE__ + +foreign import ccall "Number" jsNumber :: JSString -> Double +foreign import ccall "String" jsString :: Double -> JSString +foreign import ccall jsTrunc :: Double -> Int +foreign import ccall jsTruncW :: Double -> Int +foreign import ccall "I_toInt" jsIToInt :: ByteArray# -> Int +foreign import ccall "I_toString" jsIToString :: ByteArray# -> JSString +foreign import ccall "I_fromString" jsStringToI :: JSString -> ByteArray# +foreign import ccall "I_fromNumber" jsNumToI :: ByteArray# -> ByteArray# + +unsafeToJSString :: a -> JSString +unsafeToJSString = unsafeCoerce# jsString + +unsafeIntFromJSString :: JSString -> Maybe a +unsafeIntFromJSString s = + case jsNumber s of + d | isNaN d -> Nothing + | otherwise -> Just (unsafeCoerce# (jsTrunc d)) + +unsafeWordFromJSString :: JSString -> Maybe a +unsafeWordFromJSString s = + case jsNumber s of + d | isNaN d -> Nothing + | otherwise -> Just (unsafeCoerce# (jsTruncW d)) + +-- JSNum instances + +instance JSNum Char where + fromNumber = unsafeCoerce# jsTrunc + toNumber = unsafeCoerce# + +instance JSNum Int where + fromNumber = unsafeCoerce# jsTrunc + toNumber = unsafeCoerce# + +instance JSNum Int8 where + fromNumber n = case fromNumber n of I# n' -> I8# (narrow8Int# n') + toNumber = unsafeCoerce# + +instance JSNum Int16 where + fromNumber n = case fromNumber n of I# n' -> I16# (narrow16Int# n') + toNumber = unsafeCoerce# + +instance JSNum Int32 where + fromNumber = unsafeCoerce# jsTrunc + toNumber = unsafeCoerce# + +instance JSNum Word where + fromNumber n = + case jsTrunc (unsafeCoerce# n) of + I# n' -> W# (int2Word# n') + toNumber = unsafeCoerce# + +instance JSNum Word8 where + fromNumber w = case fromNumber w of W# w' -> W8# (narrow8Word# w') + toNumber = unsafeCoerce# + +instance JSNum Word16 where + fromNumber w = case fromNumber w of W# w' -> W16# (narrow16Word# w') + toNumber = unsafeCoerce# + +instance JSNum Word32 where + fromNumber w = case fromNumber w of W# w' -> W32# w' + toNumber = unsafeCoerce# + +instance JSNum Integer where + toNumber (S# n) = toNumber (I# n) + toNumber (J# n) = unsafeCoerce# (jsIToInt n) + fromNumber n = J# (jsNumToI (unsafeCoerce# n)) + +instance JSNum Float where + fromNumber = unsafeCoerce# + toNumber = unsafeCoerce# + +instance JSNum Double where + fromNumber = id + toNumber = id + +-- JSType instances +instance JSType Bool where + toJSString True = "true" + toJSString _ = "false" + fromJSString "true" = Just True + fromJSString "false" = Just False + fromJSString _ = Nothing +instance JSType Int where + toJSString = unsafeToJSString + fromJSString = unsafeIntFromJSString +instance JSType Int8 where + toJSString = unsafeToJSString + fromJSString = unsafeIntFromJSString +instance JSType Int16 where + toJSString = unsafeToJSString + fromJSString = unsafeIntFromJSString +instance JSType Int32 where + toJSString = unsafeToJSString + fromJSString = unsafeIntFromJSString +instance JSType Word where + toJSString = unsafeToJSString + fromJSString = unsafeWordFromJSString +instance JSType Word8 where + toJSString = unsafeToJSString + fromJSString = unsafeWordFromJSString +instance JSType Word16 where + toJSString = unsafeToJSString + fromJSString = unsafeWordFromJSString +instance JSType Word32 where + toJSString = unsafeToJSString + fromJSString = unsafeWordFromJSString + +instance JSType Float where + fromJSString s = + case jsNumber s of + d | isNaN d -> Nothing + | otherwise -> Just (unsafeCoerce# d) + toJSString = unsafeToJSString + +instance JSType Double where + fromJSString s = + case jsNumber s of + d | isNaN d -> Nothing + | otherwise -> Just d + toJSString = unsafeToJSString + +-- This is completely insane, but GHC for some reason pukes when we try to +-- use the constructors of the actual integers, so we coerce them into this +-- isomorphic type to work with them instead. +data Dummy = Small Int# | Big ByteArray# + +instance JSType Integer where + toJSString n = + case unsafeCoerce# n of + Small n' -> toJSString (I# n') + Big n' -> jsIToString n' + fromJSString s = + case jsStringToI s of + n -> Just (unsafeCoerce# (Big n)) + +instance JSType String where + toJSString = toJSStr + fromJSString = Just . fromJSStr + +instance JSType () where + toJSString _ = toJSStr "()" + fromJSString s | s == toJSStr "()" = Just () + | otherwise = Nothing + +#else + +instance JSNum Char where + toNumber = fromIntegral . ord + fromNumber = chr . round + +instance JSNum Int where + toNumber = fromIntegral + fromNumber = round +instance JSNum Int8 where + toNumber = fromIntegral + fromNumber = round +instance JSNum Int16 where + toNumber = fromIntegral + fromNumber = round +instance JSNum Int32 where + toNumber = fromIntegral + fromNumber = round + +instance JSNum Word where + toNumber = fromIntegral + fromNumber = round +instance JSNum Word8 where + toNumber = fromIntegral + fromNumber = round +instance JSNum Word16 where + toNumber = fromIntegral + fromNumber = round +instance JSNum Word32 where + toNumber = fromIntegral + fromNumber = round + +instance JSNum Double where + toNumber = id + fromNumber = id +instance JSNum Float where + toNumber = float2Double + fromNumber = double2Float + +instance JSNum Integer where + toNumber = fromInteger + fromNumber = round + +mread :: Read a => String -> Maybe a +mread s = + case reads s of + [(x, "")] -> x + _ -> Nothing + +instance JSType Int where + toJSString = toJSStr . show + fromJSString = mread . fromJSStr +instance JSType Int8 where + toJSString = toJSStr . show + fromJSString = mread . fromJSStr +instance JSType Int16 where + toJSString = toJSStr . show + fromJSString = mread . fromJSStr +instance JSType Int32 where + toJSString = toJSStr . show + fromJSString = mread . fromJSStr + +instance JSType Word where + toJSString = toJSStr . show + fromJSString = mread . fromJSStr +instance JSType Word8 where + toJSString = toJSStr . show + fromJSString = mread . fromJSStr +instance JSType Word16 where + toJSString = toJSStr . show + fromJSString = mread . fromJSStr +instance JSType Word32 where + toJSString = toJSStr . show + fromJSString = mread . fromJSStr + +instance JSType Double where + toJSString = toJSStr . show + fromJSString = mread . fromJSStr +instance JSType Float where + toJSString = toJSStr . show + fromJSString = mread . fromJSStr + +instance JSType Integer where + toJSString = toJSStr . show + fromJSString = mread . fromJSStr + +instance JSType Bool where + toJSString = toJSStr . show + fromJSString = mread . fromJSStr + +instance JSType () where + toJSString = toJSStr . show + fromJSString = mread . fromJSStr + +instance JSType String where + toJSString = toJSStr + fromJSString = Just . fromJSStr + +#endif + +-- Derived functions + +toString :: JSType a => a -> String +toString = fromJSStr . toJSString + +fromString :: JSType a => String -> Maybe a +fromString = fromJSString . toJSStr + +convert :: (JSNum a, JSNum b) => a -> b +convert = fromNumber . toNumber diff --git a/src/Data/JSTarget/AST.hs b/src/Data/JSTarget/AST.hs --- a/src/Data/JSTarget/AST.hs +++ b/src/Data/JSTarget/AST.hs @@ -150,8 +150,8 @@ data Module = Module { modPackageId :: !BS.ByteString, modName :: !BS.ByteString, - modDeps :: !(M.Map Name (S.Set Name)), - modDefs :: !(M.Map Name Exp) + modDeps :: M.Map Name (S.Set Name), + modDefs :: M.Map Name Exp } -- | Merge two modules. The module and package IDs of the second argument are diff --git a/src/Data/JSTarget/Binary.hs b/src/Data/JSTarget/Binary.hs --- a/src/Data/JSTarget/Binary.hs +++ b/src/Data/JSTarget/Binary.hs @@ -118,25 +118,27 @@ n -> error $ "Bad tag in get :: Get Stm: " ++ show n instance Binary BinOp where - put Add = putWord8 0 - put Mul = putWord8 1 - put Sub = putWord8 2 - put Div = putWord8 3 - put Mod = putWord8 4 - put And = putWord8 5 - put Or = putWord8 6 - put Eq = putWord8 7 - put Neq = putWord8 8 - put LT = putWord8 9 - put GT = putWord8 10 - put LTE = putWord8 11 - put GTE = putWord8 12 - put Shl = putWord8 13 - put ShrL = putWord8 14 - put ShrA = putWord8 15 - put BitAnd = putWord8 16 - put BitOr = putWord8 17 - put BitXor = putWord8 18 + put Add = putWord8 0 + put Mul = putWord8 1 + put Sub = putWord8 2 + put Div = putWord8 3 + put Mod = putWord8 4 + put And = putWord8 5 + put Or = putWord8 6 + put Eq = putWord8 7 + put StrictEq = putWord8 8 + put Neq = putWord8 9 + put StrictNeq = putWord8 10 + put LT = putWord8 11 + put GT = putWord8 12 + put LTE = putWord8 13 + put GTE = putWord8 14 + put Shl = putWord8 15 + put ShrL = putWord8 16 + put ShrA = putWord8 17 + put BitAnd = putWord8 18 + put BitOr = putWord8 19 + put BitXor = putWord8 20 get = (opTbl !) <$> getWord8 @@ -149,5 +151,5 @@ listArray (0, arrLen-1) es where arrLen = fromIntegral $ length es - es = [Add, Mul, Sub, Div, Mod, And, Or, Eq, Neq, LT, GT, - LTE, GTE, Shl, ShrL, ShrA, BitAnd, BitOr, BitXor] + es = [Add, Mul, Sub, Div, Mod, And, Or, Eq, StrictEq, Neq, StrictNeq, + LT, GT, LTE, GTE, Shl, ShrL, ShrA, BitAnd, BitOr, BitXor] diff --git a/src/Data/JSTarget/Op.hs b/src/Data/JSTarget/Op.hs --- a/src/Data/JSTarget/Op.hs +++ b/src/Data/JSTarget/Op.hs @@ -10,7 +10,9 @@ | And | Or | Eq + | StrictEq | Neq + | StrictNeq | LT | GT | LTE @@ -24,48 +26,52 @@ deriving (Eq) instance Show BinOp where - show Add = "+" - show Mul = "*" - show Sub = "-" - show Div = "/" - show Mod = "%" - show And = "&&" - show Or = "||" - show Eq = "==" - show Neq = "!=" - show LT = "<" - show GT = ">" - show LTE = "<=" - show GTE = ">=" - show Shl = "<<" - show ShrL = ">>>" - show ShrA = ">>" - show BitAnd = "&" - show BitOr = "|" - show BitXor = "^" + show Add = "+" + show Mul = "*" + show Sub = "-" + show Div = "/" + show Mod = "%" + show And = "&&" + show Or = "||" + show Eq = "==" + show StrictEq = "===" + show Neq = "!=" + show StrictNeq = "!==" + show LT = "<" + show GT = ">" + show LTE = "<=" + show GTE = ">=" + show Shl = "<<" + show ShrL = ">>>" + show ShrA = ">>" + show BitAnd = "&" + show BitOr = "|" + show BitXor = "^" -- | Returns the precedence of the given operator as an int. Higher number -- means higher priority. opPrec :: BinOp -> Int -opPrec Mul = 100 -opPrec Div = 100 -opPrec Mod = 100 -opPrec Add = 70 -opPrec Sub = 70 -opPrec Shl = 60 -opPrec ShrA = 60 -opPrec ShrL = 60 -opPrec LT = 50 -opPrec GT = 50 -opPrec LTE = 50 -opPrec GTE = 50 -opPrec Eq = 30 -opPrec Neq = 30 -opPrec BitAnd = 25 -opPrec BitXor = 24 -opPrec BitOr = 23 -opPrec And = 20 -opPrec Or = 10 +opPrec Mul = 100 +opPrec Div = 100 +opPrec Mod = 100 +opPrec Add = 70 +opPrec Sub = 70 +opPrec Shl = 60 +opPrec ShrA = 60 +opPrec ShrL = 60 +opPrec LT = 50 +opPrec GT = 50 +opPrec LTE = 50 +opPrec GTE = 50 +opPrec Eq = 30 +opPrec StrictEq = 30 +opPrec Neq = 30 +opPrec StrictNeq = 30 +opPrec BitAnd = 25 +opPrec BitXor = 24 +opPrec BitOr = 23 +opPrec And = 20 +opPrec Or = 10 -- | Is the given operator associative? opIsAssoc :: BinOp -> Bool diff --git a/src/Data/JSTarget/Optimize.hs b/src/Data/JSTarget/Optimize.hs --- a/src/Data/JSTarget/Optimize.hs +++ b/src/Data/JSTarget/Optimize.hs @@ -55,6 +55,7 @@ >>= smallStepInline >>= optimizeArrays >>= zapJSStringConversions + >>= inlineJSPrimitives -- | Attempt to turn two case branches into a ternary operator expression. tryTernary :: Var @@ -674,7 +675,8 @@ ("__app5", f:xs) -> Call 0 (Fast False) f xs ("__get", [o, k]) -> Index o k ("__set", [o, k, v]) -> AssignEx (Index o k) v - ("__has", [o, k]) -> BinOp Neq (Index o k) (JSLit "undefined") + ("__has", [o, k]) -> BinOp StrictNeq (Index o k) + (JSLit "undefined") _ -> ex inl ex = ex diff --git a/src/Data/JSTarget/PP.hs b/src/Data/JSTarget/PP.hs --- a/src/Data/JSTarget/PP.hs +++ b/src/Data/JSTarget/PP.hs @@ -13,17 +13,20 @@ import Control.Applicative import qualified Data.Map as M import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Char8 as BSS import Data.ByteString (ByteString) import Data.JSTarget.AST (Name (..)) import Data.ByteString.Builder -- | Pretty-printing options data PPOpts = PPOpts { - nameComments :: Bool, -- ^ Emit comments for names, where available? - useIndentation :: Bool, -- ^ Should we indent at all? - indentStr :: Builder, -- ^ String to use for each step of indentation - useNewlines :: Bool, -- ^ Use line breaks? - useSpaces :: Bool -- ^ Use spaces other than where necessary? + nameComments :: Bool, -- ^ Emit comments for externals? + externalAnnotation :: Bool, -- ^ Emit comments for names? + useIndentation :: Bool, -- ^ Should we indent at all? + indentStr :: Builder, -- ^ Indentation step. + useNewlines :: Bool, -- ^ Use line breaks? + useSpaces :: Bool, -- ^ Use spaces other than where necessary? + preserveNames :: Bool -- ^ Use STG names? } type IndentLvl = Int @@ -62,22 +65,35 @@ instance Default PPOpts where def = PPOpts { - nameComments = False, - useIndentation = False, - indentStr = " ", - useNewlines = False, - useSpaces = False + nameComments = False, + externalAnnotation = False, + useIndentation = False, + indentStr = " ", + useNewlines = False, + useSpaces = False, + preserveNames = False } -debugPPOpts :: PPOpts -debugPPOpts = def { - nameComments = True, +-- | Print code using indentation, whitespace and newlines. +withPretty :: PPOpts -> PPOpts +withPretty opts = opts { useIndentation = True, indentStr = " ", useNewlines = True, useSpaces = True } +-- | Annotate non-local, non-JS symbols with qualified names. +withAnnotations :: PPOpts -> PPOpts +withAnnotations opts = opts {nameComments = True} + +-- | Annotate externals with /* EXTERNAL */ comment. +withExtAnnotation :: PPOpts -> PPOpts +withExtAnnotation opts = opts {externalAnnotation = True} + +withHSNames :: PPOpts -> PPOpts +withHSNames opts = opts {preserveNames = True} + -- | Generate the final name for a variable. finalNameFor :: Name -> PP FinalName finalNameFor n = PP $ \_ _ ns@(nextN, m) b -> @@ -109,7 +125,25 @@ prettyProg :: Pretty a => PPOpts -> Name -> a -> (Builder, Builder) prettyProg opts mainSym ast = runPP opts $ do pp ast - buildFinalName <$> finalNameFor mainSym + hsnames <- getOpt preserveNames + if hsnames + then return $ buildStgName mainSym + else buildFinalName <$> finalNameFor mainSym + +-- | JS-mangled version of an internal name. +buildStgName :: Name -> Builder +buildStgName (Name n mq) = + byteString "$hs$" <> qual <> byteString (BSS.map mkjs n) + where + qual = case mq of + Just (_, m) -> byteString (BSS.map mkjs m) <> byteString "$" + _ -> mempty + mkjs c + | c >= 'a' && c <= 'z' = c + | c >= 'A' && c <= 'Z' = c + | c >= '0' && c <= '9' = c + | c == '$' = c + | otherwise = '_' -- | Turn a FinalName into a Builder. buildFinalName :: FinalName -> Builder diff --git a/src/Data/JSTarget/Print.hs b/src/Data/JSTarget/Print.hs --- a/src/Data/JSTarget/Print.hs +++ b/src/Data/JSTarget/Print.hs @@ -13,16 +13,22 @@ import qualified Data.ByteString.UTF8 as BS instance Pretty Var where - pp (Foreign name) = + pp (Foreign name) = do put name + doComment <- getOpt externalAnnotation + when doComment . put $ byteString "/* EXTERNAL */" pp (Internal name@(Name _ _) comment _) = do - pp name - doComment <- getOpt nameComments - when doComment $ do - when (not $ BS.null comment) $ do - put $ byteString "/* " - put comment - put $ byteString " */" + hsnames <- getOpt preserveNames + if hsnames + then put $ buildStgName name + else do + pp name + doComment <- getOpt nameComments + when doComment $ do + when (not $ BS.null comment) $ do + put $ byteString "/* " + put comment + put $ byteString " */" instance Pretty Name where pp name = finalNameFor name >>= put . buildFinalName diff --git a/src/Haste/CodeGen.hs b/src/Haste/CodeGen.hs --- a/src/Haste/CodeGen.hs +++ b/src/Haste/CodeGen.hs @@ -98,14 +98,18 @@ -- or Integer values. case (dataConNameModule con, args) of (("S#", "GHC.Integer.Type"), [StgLitArg (MachInt n)]) | tooLarge n -> do - return $ mkInteger n + return $ mkInteger n + (("True", "GHC.Types"), []) -> do + return $ lit True + (("False", "GHC.Types"), []) -> do + return $ lit False _ -> do - (tag, stricts) <- genDataCon con - (args', stricts') <- genArgsPair $ zip args stricts - -- Don't create unboxed tuples with a single element. - case (isNewtypeLikeCon con || isUnboxedTupleCon con, args') of - (True, [arg]) -> return $ evaluate arg (head stricts') - _ -> mkCon tag args' stricts' + (tag, stricts) <- genDataCon con + (args', stricts') <- genArgsPair $ zip args stricts + -- Don't create unboxed tuples with a single element. + case (isNewtypeLikeCon con || isUnboxedTupleCon con, args') of + (True, [arg]) -> return $ evaluate arg (head stricts') + _ -> mkCon tag args' stricts' where mkInteger n = array [litN 1, callForeign "I_fromBits" [array [lit lo, lit hi]]] @@ -113,7 +117,7 @@ lo = n .&. 0xffffffff hi = n `shiftR` 32 tooLarge n = n > 2147483647 || n < -2147483648 - -- Always inline bools + -- Always inline enum-likes, bools are true/false, not 1/0. mkCon l _ _ | isEnumerationDataCon con = return l mkCon tag as ss = return $ array (tag : zipWith evaluate as ss) evaluate arg True = eval arg @@ -235,11 +239,12 @@ genCase :: AltType -> StgExpr -> Id -> [StgAlt] -> JSGen Config Exp genCase t ex scrut alts = do + cfg <- getCfg ex' <- genEx ex -- Return a scrutinee variable and a function to replace all occurrences of -- the STG scrutinee with our JS one, if needed. (scrut', withScrutinee) <- case ex' of - Eval (J.Var v) -> do + Eval (J.Var v) | overwriteScrutinees cfg -> do continue $ assignVar (reorderableType scrut) v ex' oldscrut <- genVar scrut return (v, rename oldscrut v) diff --git a/src/Haste/Config.hs b/src/Haste/Config.hs --- a/src/Haste/Config.hs +++ b/src/Haste/Config.hs @@ -92,6 +92,12 @@ -- | Link the program? performLink :: Bool, + -- | Link as jslib file, instead of executable? + linkJSLib :: Bool, + + -- | Output file name when linking jslib. + linkJSLibFile :: Maybe FilePath, + -- | A function to call on each Int arithmetic primop. wrapIntMath :: Exp -> Exp, @@ -136,6 +142,20 @@ -- Defaults to True. optimize :: Bool, + -- | Overwrite scrutinees when evaluated instead of allocating a new local. + -- Defaults to False. + overwriteScrutinees :: Bool, + + -- | Annotate all external symbols and JS literals with /* EXTERNAL */ in + -- generated code. + -- Defaults to False. + annotateExternals :: Bool, + + -- | Annotate all non-local Haskell symbols and with their qualified + -- names. + -- Defaults to False. + annotateSymbols :: Bool, + -- | Emit @"use strict";@ declaration. Does not affect minification, but -- *does* affect any external JS. -- Defaults to True. @@ -145,31 +165,36 @@ -- | Default compiler configuration. defConfig :: Config defConfig = Config { - rtsLibs = stdJSLibs, - libPaths = nub [jsmodUserDir, jsmodSysDir], - targetLibPath = ".", - appStart = startOnLoadComplete, - wrapProg = False, - ppOpts = def, - outFile = \cfg f -> let ext = if outputHTML cfg - then "html" - else "js" - in replaceExtension f ext, - performLink = True, - wrapIntMath = strictly32Bits, - multiplyIntOp = safeMultiply, - verbose = False, - wholeProgramOpts = False, - sloppyTCE = False, - tracePrimops = False, - useGoogleClosure = Nothing, + rtsLibs = stdJSLibs, + libPaths = nub [jsmodUserDir, jsmodSysDir], + targetLibPath = ".", + appStart = startOnLoadComplete, + wrapProg = False, + ppOpts = def, + outFile = \cfg f -> let ext = if outputHTML cfg + then "html" + else "js" + in replaceExtension f ext, + performLink = True, + linkJSLib = False, + linkJSLibFile = Nothing, + wrapIntMath = strictly32Bits, + multiplyIntOp = safeMultiply, + verbose = False, + wholeProgramOpts = False, + sloppyTCE = False, + tracePrimops = False, + useGoogleClosure = Nothing, useGoogleClosureFlags = [], - jsExternals = [], - outputHTML = False, - showOutputable = const "No showOutputable defined in config!", - mainMod = Just ("main", "Main"), - optimize = True, - useStrict = True + jsExternals = [], + outputHTML = False, + showOutputable = const "No showOutputable defined in config!", + mainMod = Just ("main", "Main"), + optimize = True, + overwriteScrutinees = False, + annotateExternals = False, + annotateSymbols = False, + useStrict = True } instance Default Config where diff --git a/src/Haste/Environment.hs b/src/Haste/Environment.hs --- a/src/Haste/Environment.hs +++ b/src/Haste/Environment.hs @@ -1,14 +1,15 @@ {-# LANGUAGE CPP #-} -- | Paths, host bitness and other environmental information about Haste. module Haste.Environment ( - hasteSysDir, jsmodSysDir, hasteCabalSysDir, pkgSysDir, pkgSysLibDir, jsDir, - hasteUserDir, jsmodUserDir, hasteCabalUserDir, pkgUserDir, pkgUserLibDir, + hasteSysDir, jsmodSysDir, pkgSysDir, pkgSysLibDir, jsDir, + hasteUserDir, jsmodUserDir, pkgUserDir, pkgUserLibDir, hasteGhcLibDir, hostWordSize, ghcPkgBinary, ghcBinary, - hasteBinary, hastePkgBinary, hasteInstHisBinary, hasteCabalBinary, - hasteCopyPkgBinary, closureCompiler, portableHaste, - hasteNeedsReboot, hasteCabalNeedsReboot, bootFile + hasteBinDir, hasteBinary, hastePkgBinary, hasteInstHisBinary, + hasteCabalBinary, hasteCopyPkgBinary, + closureCompiler, bootFile, + portableHaste, hasteNeedsReboot ) where import System.IO.Unsafe import Data.Bits @@ -16,12 +17,24 @@ import Control.Shell hiding (hClose) import Paths_haste_compiler import System.IO +import System.Info import Haste.GHCPaths (ghcPkgBinary, ghcBinary) import Haste.Version #if defined(PORTABLE) import System.Environment (getExecutablePath) #endif +-- | Subdirectory under Haste's root directory where all the stuff for this +-- version lives. Use "windows" instead of "mingw32", since this is what +-- cabal prefers. +hasteVersionSubDir :: FilePath +hasteVersionSubDir = arch ++ "-" ++ myos ++ "-" ++ myver + where + myos + | os == "mingw32" = "windows" + | otherwise = os + myver = showBootVersion bootVersion + -- | Directory to search for GHC settings. Always equal to 'hasteSysDir'. hasteGhcLibDir :: FilePath hasteGhcLibDir = hasteSysDir @@ -34,12 +47,13 @@ -- | Haste system directory. Identical to @hasteUserDir@ unless built with -- -f portable. hasteSysDir :: FilePath -hasteSysDir = - joinPath . init . init . splitPath $ unsafePerformIO getExecutablePath +hasteSysDir = dir hasteVersionSubDir + where + dir = joinPath . init . init . splitPath $ unsafePerformIO getExecutablePath -- | Haste @bin@ directory. hasteBinDir :: FilePath -hasteBinDir = hasteSysDir "bin" +hasteBinDir = takeDirectory $ unsafePerformIO getExecutablePath -- | Haste JS file directory. jsDir :: FilePath @@ -69,19 +83,15 @@ hasteUserDir :: FilePath Right hasteUserDir = unsafePerformIO . shell . withAppDirectory "haste" $ \d -> do - return $ d showBootVersion bootVersion + return $ d hasteVersionSubDir -- | Directory where user .jsmod files are stored. jsmodSysDir :: FilePath -jsmodSysDir = hasteSysDir "jsmods" - --- | Base directory for haste-cabal; system packages. -hasteCabalSysDir :: FilePath -hasteCabalSysDir = hasteSysDir "libraries" +jsmodSysDir = hasteSysDir -- | Base directory for Haste's system libraries. pkgSysLibDir :: FilePath -pkgSysLibDir = hasteCabalSysDir "lib" +pkgSysLibDir = hasteSysDir -- | Directory housing package information. pkgSysDir :: FilePath @@ -89,15 +99,11 @@ -- | Directory where user .jsmod files are stored. jsmodUserDir :: FilePath -jsmodUserDir = hasteUserDir "jsmods" - --- | Base directory for haste-cabal. -hasteCabalUserDir :: FilePath -hasteCabalUserDir = hasteUserDir "libraries" +jsmodUserDir = hasteUserDir -- | Directory containing library information. pkgUserLibDir :: FilePath -pkgUserLibDir = hasteCabalUserDir "lib" +pkgUserLibDir = hasteUserDir -- | Directory housing package information. pkgUserDir :: FilePath @@ -111,25 +117,31 @@ hostWordSize = bitSize (undefined :: CIntPtr) #endif +-- | File extension of binaries on this system. +binaryExt :: String +binaryExt + | os == "mingw32" = ".exe" + | otherwise = "" + -- | The main Haste compiler binary. hasteBinary :: FilePath -hasteBinary = hasteBinDir "hastec" +hasteBinary = hasteBinDir "hastec" ++ binaryExt -- | Binary for haste-pkg. hastePkgBinary :: FilePath -hastePkgBinary = hasteBinDir "haste-pkg" +hastePkgBinary = hasteBinDir "haste-pkg" ++ binaryExt -- | Binary for haste-copy-pkg. hasteCopyPkgBinary :: FilePath -hasteCopyPkgBinary = hasteBinDir "haste-copy-pkg" +hasteCopyPkgBinary = hasteBinDir "haste-copy-pkg" ++ binaryExt -- | Binary for haste-pkg. hasteCabalBinary :: FilePath -hasteCabalBinary = hasteBinDir "haste-cabal" +hasteCabalBinary = hasteBinDir "haste-cabal" ++ binaryExt -- | Binary for haste-install-his. hasteInstHisBinary :: FilePath -hasteInstHisBinary = hasteBinDir "haste-install-his" +hasteInstHisBinary = hasteBinDir "haste-install-his" ++ binaryExt -- | JAR for Closure compiler. closureCompiler :: FilePath @@ -146,12 +158,7 @@ #ifdef PORTABLE hasteNeedsReboot = False #else -hasteNeedsReboot = hasteCabalNeedsReboot -#endif - --- | Does haste-cabal possibly needs rebooting? -hasteCabalNeedsReboot :: Bool -hasteCabalNeedsReboot = unsafePerformIO $ do +hasteNeedsReboot = unsafePerformIO $ do exists <- shell $ isFile bootFile case exists of Right True -> do @@ -165,3 +172,4 @@ return True _ -> do return True +#endif diff --git a/src/Haste/JSLib.hs b/src/Haste/JSLib.hs new file mode 100644 --- /dev/null +++ b/src/Haste/JSLib.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE RecordWildCards #-} +-- | JSLib file format. +module Haste.JSLib (createJSLib, readModule) where +import Control.Applicative +import Control.Monad +import Data.Binary +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.UTF8 as BS +import Data.JSTarget +import System.Directory (doesFileExist) +import System.IO + +jslibMagicNumber :: Word64 +jslibMagicNumber = 0x42494c534a -- "JSLIB\0\0\0" + +jslibCurrentVersion :: Word8 +jslibCurrentVersion = 0 + +jslibMaxSize :: Integer +jslibMaxSize = 2^(32 :: Int)-1 + +-- | Static size, ever unchanging part of the file format. +data JSLibStaticHdr = JSLibStaticHdr { + hdrMagicNumber :: !Word64, -- ^ Always "JSLIB\0\0\0". + hdrVersion :: !Word8, -- ^ JSLib format version. + hdrSize :: !Word32 -- ^ Size of the rest of the header, in bytes. + } + +-- | Library metadata: package ID and info on how to find the actual data. +data JSLibMetadata = JSLibMetadata { + mdPkgId :: !BS.ByteString, -- ^ Library's package ID. + mdModules :: ![(BS.ByteString, (Word32, Word32))] + -- ^ Offsets and sizes of all modules in + -- this lib, offsets starting from the + -- end of the header. + } + +data JSLibHdr = JSLibHdr { + hdrStaticHdr :: JSLibStaticHdr, + hdrMetadata :: JSLibMetadata + } + +instance Binary JSLibStaticHdr where + put JSLibStaticHdr {..} = do + put hdrMagicNumber + put hdrVersion + put hdrSize + get = do + JSLibStaticHdr <$> get <*> get <*> get + +instance Binary JSLibMetadata where + put JSLibMetadata {..} = put mdPkgId >> put mdModules + get = JSLibMetadata <$> get <*> get + +instance Binary JSLibHdr where + put JSLibHdr {..} = put hdrStaticHdr >> put hdrMetadata + get = JSLibHdr <$> get <*> get + +-- | Create a jslib file by the given name, for the package with the given +-- package key, containing the modules described by the given list of files. +createJSLib :: FilePath -> BS.ByteString -> [FilePath] -> IO () +createJSLib jslibfile pkgid jsmodfiles = do + mods <- genModOffList 0 jsmodfiles + let hdr = JSLibHdr { + hdrStaticHdr = JSLibStaticHdr { + hdrMagicNumber = jslibMagicNumber, + hdrVersion = jslibCurrentVersion, + hdrSize = fromIntegral . BSL.length $ encode (hdrMetadata hdr) + }, + hdrMetadata = JSLibMetadata { + mdPkgId = pkgid, + mdModules = mods + } + } + BSL.writeFile jslibfile $ encode hdr + mapM_ (BSL.readFile >=> BSL.appendFile jslibfile) jsmodfiles + where + genModOffList off (f:fs) = do + when (off > jslibMaxSize) $ error "jslib became too large!" + (nm, sz) <- withBinaryFile f ReadMode $ \h -> do + sz <- hFileSize h + m <- decode `fmap` BSL.hGetContents h + when (modPackageId m /= pkgid) $ + error $ "Module package key mismatch: expected " ++ BS.toString pkgid + ++ " but saw " ++ BS.toString (modPackageId m) + return (modName m, sz) + + ms <- genModOffList (off + sz) fs + return $ (nm, (fromIntegral off, fromIntegral sz)) : ms + genModOffList _ _ = do + return [] + +-- | Read a module from a jslib file. Returns @Nothing@ if the jslib file does +-- not exist or does not contain the requested module. +readModule :: FilePath -> String -> IO (Maybe Module) +readModule pkgfile modname = do + exists <- doesFileExist pkgfile + if exists + then withBinaryFile pkgfile ReadMode $ \h -> do + magic <- decode <$> BSL.hGet h 8 + when (magic /= jslibMagicNumber) $ error "Bad jslib magic number!" + version <- decode <$> BSL.hGet h 1 + when (version > jslibCurrentVersion) $ error "Bad jslib format version!" + size <- decode <$> BSL.hGet h 4 + md <- decode <$> BSL.hGet h (fromIntegral (size :: Word32)) + case lookup (BS.fromString modname) $ mdModules md of + Just (off, sz) -> do + hSeek h RelativeSeek (fromIntegral off) + Just . decode <$> BSL.hGet h (fromIntegral sz) + _ -> do + return Nothing + else return Nothing diff --git a/src/Haste/Linker.hs b/src/Haste/Linker.hs --- a/src/Haste/Linker.hs +++ b/src/Haste/Linker.hs @@ -1,5 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, - FlexibleContexts, OverloadedStrings #-} + FlexibleContexts, OverloadedStrings, CPP #-} module Haste.Linker (link) where import Haste.Config import Haste.Module @@ -19,7 +19,11 @@ -- This will need to change when we start supporting building "binaries" -- using cabal, since we'll have all sorts of funny package names then. mainSym :: Name +#if __GLASGOW_HASKELL__ < 709 mainSym = name "main" (Just ("main", ":Main")) +#else +mainSym = name "main" (Just ("main", "Main")) +#endif -- | Link a program using the given config and input file name. link :: Config -> BS.ByteString -> FilePath -> IO () @@ -136,7 +140,7 @@ _ -> left v -- | Return the module at the given path, loading it into cache if it's not --- already there. +-- already there. Modules are preferentially loaded from jslib file. getModule :: [FilePath] -> BS.ByteString -> BS.ByteString -> DepM (Maybe Module) getModule libpaths pkgid modname = do st <- get diff --git a/src/Haste/Module.hs b/src/Haste/Module.hs --- a/src/Haste/Module.hs +++ b/src/Haste/Module.hs @@ -1,12 +1,17 @@ +{-# LANGUAGE CPP #-} -- | Read and write JSMods. module Haste.Module (writeModule, readModule) where import Module (moduleNameSlashes, mkModuleName) import qualified Data.ByteString.Lazy as B import Control.Shell import Control.Applicative +import Control.Monad (when, filterM) import Data.JSTarget import Data.Binary +import Data.List (isSuffixOf) import qualified Data.ByteString.UTF8 as BS +import qualified Haste.JSLib as JSLib +import qualified System.IO as IO -- | The file extension to use for modules. jsmodExt :: Bool -> String @@ -19,38 +24,98 @@ -- | Write a module to file, with the extension specified in `fileExt`. -- Assuming that fileExt = "jsmod", a module Foo.Bar is written to --- basepath/Foo/Bar.jsmod +-- @basepath/Foo/Bar.jsmod@. +-- -- If any directory in the path where the module is to be written doesn't -- exist, it gets created. +-- +-- Boot modules and "normal" modules get merged at this stage. writeModule :: FilePath -> Module -> Bool -> IO () writeModule basepath m@(Module pkgid modname _ _) boot = fromRight "writeModule" . shell $ do mkdir True (takeDirectory path) - liftIO $ B.writeFile path (encode m) + mcompanion <- readMod basepath pkgstr modstr (not boot) + m' <- case mcompanion of + Just companion -> do + bootfileExists <- isFile bootpath + when bootfileExists $ rm bootpath + return $ merge' m companion + _ -> do + return m + liftIO . B.writeFile path $ encode m' where - path = - moduleFilePath basepath (BS.toString pkgid) (BS.toString modname) boot + pkgstr = BS.toString pkgid + modstr = BS.toString modname + path = moduleFilePath basepath pkgstr modstr boot + bootpath = moduleFilePath basepath pkgstr modstr True + merge' = if boot then merge else flip merge -- | Read a module from file. If the module is not found at the specified path, -- libpath/path is tried instead. Returns Nothing is the module is not found -- on either path. readModule :: FilePath -> String -> String -> IO (Maybe Module) readModule basepath pkgid modname = fromRight "readModule" . shell $ do + libfile <- (basepath ) `fmap` jslibFileName basepath pkgid + mmlib <- liftIO $ JSLib.readModule libfile modname mm <- readMod basepath pkgid modname False mmboot <- readMod basepath pkgid modname True - case (mm, mmboot) of - (Just m, Nothing) -> return $ Just m - (Just m, Just mboot) -> return . Just $ merge mboot m - _ -> return Nothing + case (mmlib, mm, mmboot) of + (Just m, _, _) -> return $ Just m + (_, Just m, Nothing) -> return $ Just m + (_, Just m, Just mboot) -> return . Just $ merge mboot m + _ -> return Nothing +-- | Get the file name for a given package identifier. +jslibFileName :: FilePath -> String -> Shell FilePath +jslibFileName basepath pkgid + | pkgid `elem` specials = do + dirs <- ls basepath + case filter (and . zipWith (==) pkgid) dirs of + (dir:_) -> do + files <- ls (basepath dir) + case filter (".jslib" `isSuffixOf`) files of + (f:_) -> return $ dir f + _ -> fail $ "Package " ++ pkgid ++ " has no jslib file!" + _ -> do + return stdname + | otherwise = do +#if __GLASGOW_HASKELL__ < 709 + return stdname +#else + dirs <- filter (pkgid `isSuffixOf`) . map (basepath ) <$> ls basepath + dirs' <- filterM isDirectory dirs + case dirs' of + ds | not (null ds) -> findLibFile ds + | otherwise -> return stdname +#endif + where + findLibFile (d:ds) = do + fs <- map (d ) . filter (libfilesuffix `isSuffixOf`) <$> ls d + fs' <- filterM isFile fs + case fs' of + (f:_) -> return f + _ -> findLibFile ds + findLibFile _ = do + return stdname + + -- Use this for non-special packages + stdname = pkgid "libHS" ++ pkgid <.> "jslib" + -- These package ids are special and come without version number + specials = ["ghc-prim", "base", "integer-gmp"] + libfilesuffix = pkgid <.> "jslib" + readMod :: FilePath -> String -> String -> Bool -> Shell (Maybe Module) readMod basepath pkgid modname boot = do x <- isFile path let path' = if x then path else syspath isF <- isFile path' if isF - then Just . decode <$> liftIO (B.readFile path') - else return Nothing + then do + liftIO $ IO.withFile path' IO.ReadMode $ \h -> do + m <- decode <$> (B.hGet h . fromInteger =<< IO.hFileSize h) + m `seq` return (Just m) + else do + return Nothing where path = moduleFilePath "." pkgid modname boot syspath = moduleFilePath basepath pkgid modname boot diff --git a/src/Haste/Opts.hs b/src/Haste/Opts.hs --- a/src/Haste/Opts.hs +++ b/src/Haste/Opts.hs @@ -2,27 +2,35 @@ import System.Console.GetOpt import Haste.Config import Haste.Environment -import Data.JSTarget.PP (debugPPOpts) +import Data.JSTarget.PP (PPOpts, withExtAnnotation, withAnnotations, withPretty, withHSNames) import Data.List import Control.Shell (()) -- | Haste's command line options. The boolean indicates whether we're running --- unbooted or not. When unbooted, --libinstall will install jsmods into the --- system jsmod dir rather than the user one. -hasteOpts :: Bool -> [OptDescr (Config -> Config)] -hasteOpts unbooted = [ +-- unbooted or not. +hasteOpts :: [OptDescr (Config -> Config)] +hasteOpts = [ + Option "" ["annotate-externals"] + (NoArg $ \cfg -> cfg {ppOpts = withExtAnnotation (ppOpts cfg)}) $ + "Annotate all JavaScript-native symbols and inline JavaScript " ++ + "in generated code with /* EXTERNAL */.", + Option "" ["annotate-symbols"] + (NoArg $ \cfg -> cfg {ppOpts = withAnnotations (ppOpts cfg)}) $ + "Annotate all non-external, non-local symbols with their " ++ + "qualified Haskell names.", Option "" ["debug"] - (NoArg $ \cfg -> cfg {ppOpts = debugPPOpts}) $ - "Output indented, fairly readable code, with all " ++ - "external names included in comments.", + (NoArg $ \cfg -> cfg {ppOpts = debugPPOpts (ppOpts cfg)}) $ + "Output annotated, pretty-printed JavaScript code. Equivalent to " ++ + "--annotate externals --preserve-names --pretty-print.", Option "" ["ddisable-js-opts"] (NoArg $ \cfg -> cfg {optimize = False}) $ - "Don't perform any optimizations on the JS at all.", + "Don't perform any optimizations on the JavaScript at all. " ++ + "This notably includes tail call optimization.", Option "" ["dtrace-primops"] (NoArg $ \cfg -> cfg {tracePrimops = True, rtsLibs = debugLib : rtsLibs cfg}) $ "Trace primops. Not really useful unless Haste was booted with " ++ - "option.", + "primop tracing enabled.", Option "" ["dont-link"] (NoArg $ \cfg -> cfg {performLink = False}) $ "Don't link generated .jsmod files into a .js blob.", @@ -33,22 +41,19 @@ Option "?" ["help"] (NoArg id) $ "Display this message.", - Option "" ["libinstall"] - (NoArg $ \cfg -> cfg {targetLibPath = if unbooted - then jsmodSysDir - else jsmodUserDir, - performLink = False}) $ - "Install .jsmod files into the user's library. " ++ - "Implies --dont-link.", + Option "" ["link-jslib"] + (OptArg (\file cfg -> cfg {linkJSLib = True, + linkJSLibFile = file}) "FILE") $ + "Create a jslib file instead of an executable.", Option "" ["no-use-strict"] (NoArg $ \cfg -> cfg {useStrict = False}) $ "Do not emit '\"use strict\";' declaration. Does not affect " ++ - "minifier behavior, but *does* affect any external JS included " ++ - "with --with-js.", + "minifier behavior, but *does* affect any external JavaScript " ++ + "included using --with-js.", Option "" ["onexec"] (NoArg $ \cfg -> cfg {appStart = startCustom "onexec"}) $ - "Launch application immediately when the JS file is loaded. " ++ - "Shorthand for --start=onexec.", + "Launch application immediately when the JavaScript file is " ++ + "loaded. Shorthand for --start=onexec.", Option "" ["onload"] (NoArg $ \cfg -> cfg {appStart = startCustom "onload"}) $ "Launch application on window.onload. " ++ @@ -63,7 +68,7 @@ "--opt-all --opt-unsafe-ints", Option "" ["opt-minify"] (NoArg updateClosureCfg) $ - "Minify JS output using Google Closure compiler.", + "Minify JavaScript output using Google Closure compiler.", Option "" ["opt-minify-flag"] (ReqArg updateClosureFlags "FLAG") $ "Pass a flag to Closure. " ++ @@ -75,7 +80,7 @@ "--opt-vague-ints", Option "" ["opt-unsafe-mult"] (NoArg unsafeMul) $ - "Use Javascript's built-in multiplication operator for " + "Use JavaScript's built-in multiplication operator for " ++ "fixed precision integer multiplication. This may speed " ++ "up Int multiplication by a factor of at least four, " ++ "but may give incorrect results when the product " @@ -92,21 +97,31 @@ (NoArg enableWholeProgramOpts) $ "Perform optimizations over the whole program during linking. " ++ "May significantly increase link time.", + Option "" ["overwrite-scrutinees"] + (NoArg $ \cfg -> cfg {overwriteScrutinees = True}) $ + "Overwrite scrutinees when evaluated rather than allocating " ++ + "a new local for the evaluated value. This is largely experimental.", Option "o" ["out"] (ReqArg (\f cfg -> cfg {outFile = \_ _ -> f}) "FILE") $ - "Write JS output to FILE.", + "Write JavaScript output to FILE.", Option "" ["outdir"] (ReqArg (\d cfg -> cfg {targetLibPath = d}) "DIR") $ "Write intermediate files to DIR.", Option "" ["output-html"] (NoArg $ \cfg -> cfg {outputHTML = True}) $ - "Write the JS output to an HTML file together with a simple " ++ - "HTML skeleton.", + "Write the JavaScript output to an HTML file together with a " ++ + "minimal HTML skeleton.", Option "" ["own-namespace"] (NoArg $ \cfg -> cfg {wrapProg = True}) $ "Wrap the whole program in a closure to avoid polluting the " ++ "global namespace. Incurs a performance hit, and makes " ++ "minification slightly less effective.", + Option "" ["preserve-names"] + (NoArg $ \cfg -> cfg {ppOpts = withHSNames (ppOpts cfg)}) $ + "Preserve Haskell names in JS code as far as possible.", + Option "" ["pretty-print"] + (NoArg $ \cfg -> cfg {ppOpts = withPretty (ppOpts cfg)}) $ + "Pretty-print JavaScript output.", Option "" ["start"] (ReqArg (\start cfg -> cfg {appStart = startCustom start}) "CODE") $ @@ -126,8 +141,8 @@ Option "" ["with-js"] (ReqArg (\js c -> c {jsExternals = jsExternals c ++ commaBreak js}) "FILES") $ - "Link the given comma-separated list of JS files into the final " ++ - "JS bundle." + "Link the given comma-separated list of JavaScript files into " ++ + "the final .js file." ] helpHeader :: String @@ -210,3 +225,6 @@ libs = rtsLibs cfg unicode = jsDir "unicode.js" cheap = jsDir "cheap-unicode.js" + +debugPPOpts :: PPOpts -> PPOpts +debugPPOpts = withPretty . withHSNames . withExtAnnotation diff --git a/src/Haste/PrimOps.hs b/src/Haste/PrimOps.hs --- a/src/Haste/PrimOps.hs +++ b/src/Haste/PrimOps.hs @@ -23,6 +23,7 @@ DoubleNegOp -> Right $ binOp Sub (litN 0) (head xs) FloatNegOp -> Right $ binOp Sub (litN 0) (head xs) NotOp -> Right $ not_ (head xs) -- bitwise + NotIOp -> Right $ not_ (head xs) -- bitwise -- Conversions ChrOp -> Right $ head xs @@ -31,6 +32,8 @@ Int2WordOp -> Right $ binOp ShrL (head xs) (litN 0) Int2FloatOp -> Right $ head xs Int2DoubleOp -> Right $ head xs + Word2FloatOp -> Right $ head xs + Word2DoubleOp -> Right $ head xs Double2IntOp -> Right $ binOp (BitAnd) (head xs) (litN 0xffffffff) Double2FloatOp -> Right $ head xs Float2IntOp -> Right $ binOp (BitAnd) (head xs) (litN 0xffffffff) @@ -72,6 +75,9 @@ IntLeOp -> bOp LTE IntEqOp -> bOp Eq IntNeOp -> bOp Neq + AndIOp -> bOp BitAnd + OrIOp -> bOp BitOr + XorIOp -> bOp BitXor -- Word ops WordAddOp -> wordMath $ bOp Add @@ -303,6 +309,7 @@ PopCnt8Op -> Right $ callForeign "popCnt" [head xs] PopCnt16Op -> Right $ callForeign "popCnt" [head xs] PopCnt32Op -> Right $ callForeign "popCnt" [head xs] + PopCnt64Op -> Right $ callForeign "popCnt64" [head xs] DelayOp -> Right $ defState SeqOp -> Right $ eval $ head xs AtomicallyOp -> Right $ callSaturated (xs !! 0) [] diff --git a/src/Haste/Version.hs b/src/Haste/Version.hs --- a/src/Haste/Version.hs +++ b/src/Haste/Version.hs @@ -12,7 +12,7 @@ -- | Current Haste version. hasteVersion :: Version -hasteVersion = Version [0, 5, 0, 1] [] +hasteVersion = Version [0,5,1,0] [] -- | Current Haste version as an Int. The format of this version number is -- MAJOR*10 000 + MINOR*100 + MICRO. @@ -39,7 +39,7 @@ showBootVersion :: BootVer -> String showBootVersion (BootVer ver ghcver) = - "haste-" ++ showVersion ver ++ "_ghc-" ++ showVersion ghcver + "haste-" ++ showVersion ver ++ "-ghc-" ++ showVersion ghcver parseBootVersion :: String -> Maybe BootVer parseBootVersion = @@ -48,6 +48,6 @@ parse = readP_to_S $ do _ <- string "haste-" hastever <- parseVersion - _ <- string "_ghc-" + _ <- string "-ghc-" ghcver <- parseVersion return $ BootVer hastever ghcver diff --git a/src/haste-boot.hs b/src/haste-boot.hs --- a/src/haste-boot.hs +++ b/src/haste-boot.hs @@ -18,11 +18,19 @@ import Control.Monad.IO.Class (liftIO) import Haste.Args import System.Console.GetOpt +import GHC.Paths (libdir) +import System.Info (os) +import System.Directory (copyPermissions) +import System.FilePath (takeDirectory) #if __GLASGOW_HASKELL__ >= 710 +ghcMajor = "7.10" libDir = "ghc-7.10" +primVersion = "0.4.0.0" #else +ghcMajor = "7.8" libDir = "ghc-7.8" +primVersion = "0.3.0.0" #endif downloadFile :: String -> Shell BS.ByteString @@ -45,20 +53,22 @@ useLocalLibs :: Bool, tracePrimops :: Bool, forceBoot :: Bool, - populateSetupExeCache :: Bool, - initialPortableBoot :: Bool + initialPortableBoot :: Bool, + getHasteCabal :: Bool, + verbose :: Bool } defCfg :: Cfg #ifdef PORTABLE defCfg = Cfg { - getLibs = True, + getLibs = False, getClosure = False, useLocalLibs = False, tracePrimops = False, forceBoot = False, - populateSetupExeCache = True, - initialPortableBoot = False + initialPortableBoot = False, + getHasteCabal = True, + verbose = False } #else defCfg = Cfg { @@ -67,8 +77,9 @@ useLocalLibs = False, tracePrimops = False, forceBoot = False, - populateSetupExeCache = True, - initialPortableBoot = False + initialPortableBoot = False, + getHasteCabal = True, + verbose = False } #endif @@ -77,7 +88,7 @@ useLocalLibs = True, forceBoot = True, getClosure = False, - populateSetupExeCache = False + getHasteCabal = False } setInitialPortableBoot :: Cfg -> Cfg @@ -86,7 +97,8 @@ useLocalLibs = True, forceBoot = True, getClosure = True, - initialPortableBoot = True + initialPortableBoot = True, + getHasteCabal = True } specs :: [OptDescr (Cfg -> Cfg)] @@ -95,7 +107,7 @@ Option "" ["dev"] (NoArg devBoot) $ "Boot Haste for development. Implies --force " ++ - "--local --no-closure --no-populate-setup-exe-cache" + "--local --no-closure --no-haste-cabal" , Option "" ["force"] #else Option "" ["force"] @@ -105,7 +117,8 @@ , Option "" ["initial"] (NoArg setInitialPortableBoot) $ "Prepare boot files for binary distribution. Should only ever " ++ - "be called by the release build scripts, never by users." + "be called by the release build scripts, never by users.\n" ++ + "Implies --local --force." #ifndef PORTABLE , Option "" ["local"] (NoArg $ \cfg -> cfg {useLocalLibs = True}) $ @@ -120,33 +133,37 @@ "Don't download Closure compiler. You won't be able " ++ "to use --opt-minify, unless you manually " ++ "give hastec the path to compiler.jar." + , Option "" ["no-haste-cabal"] + (NoArg $ \cfg -> cfg {getHasteCabal = False}) $ + "Don't install haste-cabal. This is probably not " ++ + "what you want." , Option "" ["no-libs"] (NoArg $ \cfg -> cfg {getLibs = False}) $ "Don't install any libraries. This is probably not " ++ "what you want." - , Option "" ["no-populate-setup-exe-cache"] - (NoArg $ \cfg -> cfg {populateSetupExeCache = False}) $ - "Don't populate Cabal's setup-exe-cache. Speeds up boot, " ++ - "but vill fail spectacularly unless your setup-exe-cache " ++ - "is already populated." , Option "" ["trace-primops"] (NoArg $ \cfg -> cfg {tracePrimops = True}) $ "Build standard libs for tracing of primitive " ++ "operations. Only use if you're debugging the code " ++ "generator." + , Option "v" ["verbose"] + (NoArg $ \cfg -> cfg {verbose = True}) $ + "Print absolutely everything." #endif ] hdr :: String hdr = "Fetch, build and install all libraries necessary to use Haste.\n" +data CabalOp = Configure | Build | Install | Clean + main :: IO () main = do args <- getArgs case parseArgs specs hdr args of Right (mkConfig, _) -> do let cfg = mkConfig defCfg - when (hasteNeedsReboot || hasteCabalNeedsReboot || forceBoot cfg) $ do + when (hasteNeedsReboot || forceBoot cfg) $ do res <- shell $ if useLocalLibs cfg then bootHaste cfg "." else withTempDirectory "haste" $ bootHaste cfg @@ -157,44 +174,86 @@ putStrLn halp bootHaste :: Cfg -> FilePath -> Shell () -bootHaste cfg tmpdir = inDirectory tmpdir $ do - removeBootFile <- isFile bootFile - when removeBootFile $ rm bootFile - when (getLibs cfg) $ do - when (not $ useLocalLibs cfg) $ do - fetchLibs tmpdir - when (populateSetupExeCache cfg) $ do - void $ run "cabal" ["update"] "" - void $ run "cabal" ["install", "-j", "populate-setup-exe-cache"] "" - inDirectory "popcache" . void $ run "cabal" ["install", "-j"] "" - void $ run "ghc-pkg" ["unregister", "haste-populate-configure"] "" - void $ run "ghc-pkg" ["unregister", "populate-setup-exe-cache"] "" +bootHaste cfg tmpdir = + withEnv "nodosfilewarning" (const "1") . inDirectory tmpdir $ do + removeBootFile <- isFile bootFile + when removeBootFile $ rm bootFile + when (getLibs cfg) $ do + -- Don't clear dir when it contains binaries; portable should only be built + -- by scripts anyway, so this dir ought to be clean. + when (not portableHaste) $ do + mapM_ clearDir [pkgUserLibDir, jsmodUserDir, pkgUserDir, + pkgSysLibDir, jsmodSysDir, pkgSysDir] - when (not portableHaste || initialPortableBoot cfg) $ do - mapM_ clearDir [hasteCabalUserDir, jsmodUserDir, pkgUserDir, - hasteCabalSysDir, jsmodSysDir, pkgSysDir] - void $ run hastePkgBinary ["init", pkgSysDir] "" - buildLibs cfg + when (getHasteCabal cfg) $ do + installHasteCabal portableHaste tmpdir - when (initialPortableBoot cfg) $ do - mapM_ relocate ["array", "bytestring", "containers", "data-default", - "data-default-class", "data-default-instances-base", - "data-default-instances-containers", - "data-default-instances-dlist", - "data-default-instances-old-locale", - "deepseq", "dlist", "haste-lib", "integer-gmp", - "monads-tf", "old-locale", "transformers", "time"] + when (not $ useLocalLibs cfg) $ do + fetchLibs tmpdir - when (getClosure cfg) $ do - installClosure - file bootFile (showBootVersion bootVersion) + when (not portableHaste || initialPortableBoot cfg) $ do + mkdir True hasteSysDir + copyGhcSettings hasteSysDir + void $ run hastePkgBinary ["init", pkgSysDir] "" + buildLibs cfg + when (initialPortableBoot cfg) $ do + mapM_ relocate ["array", "bytestring", "containers", "base", + "deepseq", "dlist", "haste-prim", "time", "haste-lib", + "monads-tf", "old-locale", "transformers", "integer-gmp"] + + when (getClosure cfg) $ do + installClosure + file bootFile (showBootVersion bootVersion) + clearDir :: FilePath -> Shell () clearDir dir = do exists <- isDirectory dir when exists $ rmdir dir +installHasteCabal :: Bool -> FilePath -> Shell () +installHasteCabal portable tmpdir = do + echo "Downloading haste-cabal from GitHub" + f <- decompress `fmap` downloadFile hasteCabalUrl + if os == "linux" + then do + mkdir True hasteCabalRootDir + liftIO . unpack hasteCabalRootDir $ read f + liftIO $ copyPermissions + hasteBinary + (hasteCabalRootDir "haste-cabal/haste-cabal.bin") + file (hasteBinDir hasteCabalFile) launcher + else do + liftIO $ BS.writeFile (hasteBinDir hasteCabalFile) f + liftIO $ copyPermissions hasteBinary (hasteBinDir hasteCabalFile) + where + baseUrl = "http://valderman.github.io/haste-libs/" + hasteCabalUrl + | os == "linux" = baseUrl ++ "haste-cabal.linux.tar.bz2" + | otherwise = baseUrl ++ "haste-cabal" <.> os <.> "bz2" + hasteCabalFile = "haste-cabal" ++ if os == "mingw32" then ".exe" else "" + hasteCabalRootDir + | portable = hasteBinDir ".." + | otherwise = hasteSysDir + + -- We need to determine the haste-cabal libdir at runtime if we're + -- portable + launcher + | portable = unlines [ + "#!/bin/bash", + "HASTEC=\"$(dirname $0)/hastec\"", + "DIR=\"$($HASTEC --print-libdir)/../haste-cabal\"", + "export LD_LIBRARY_PATH=$DIR", + "exec $DIR/haste-cabal.bin $@" + ] + | otherwise = unlines [ + "#!/bin/bash", + "DIR=\"" ++ hasteCabalRootDir "haste-cabal" ++ "\"", + "export LD_LIBRARY_PATH=$DIR", + "exec $DIR/haste-cabal.bin $@" + ] + -- | Fetch the Haste base libs. fetchLibs :: FilePath -> Shell () fetchLibs tmpdir = do @@ -223,56 +282,96 @@ -- Set up dirs and copy includes mkdir True $ pkgSysLibDir cpDir "include" hasteSysDir + + inDirectory ("utils" "unlit") $ do + let out = if os == "mingw32" then "unlit.exe" else "unlit" + static = if os == "darwin" then [] else ["-static"] + dash_s = if os == "darwin" then [] else ["-s"] + run_ "gcc" (["-o" ++ out, "-O2", "unlit.c"]++static) "" + run_ "strip" (dash_s ++ [out]) "" + cp out (hasteSysDir out) + run_ hastePkgBinary ["update", "--global", "libraries" "rts.pkg"] "" inDirectory "libraries" $ do inDirectory libDir $ do -- Install ghc-prim inDirectory "ghc-prim" $ do - hasteCabal ["configure", "--solver", "topdown"] - hasteCabal $ ["build", "--install-jsmods"] ++ ghcOpts - run_ hasteInstHisBinary ["ghc-prim-0.3.0.0", "dist" "build"] "" - run_ hastePkgBinary ["update", "--global", "packageconfig"] "" + hasteCabal Install ["--solver", "topdown"] + -- To get the GHC.Prim module in spite of pretending to have + -- build-type: Simple + let osxprim = if os == "darwin" then "-osx" else "" + run_ hastePkgBinary ["unregister", "--global","ghc-prim"] "" + run_ hastePkgBinary ["update", "--global", + "ghc-prim-"++primVersion++osxprim++".conf"] "" + -- Install integer-gmp; double install shouldn't be needed anymore. - run_ hasteCopyPkgBinary ["Cabal"] "" inDirectory "integer-gmp" $ do - hasteCabal ("install" : "--solver" : "topdown" : ghcOpts) + hasteCabal Install ["--solver", "topdown"] -- Install base inDirectory "base" $ do - basever <- file "base.cabal" >>= return - . dropWhile (not . isDigit) - . head - . filter (not . null) - . filter (and . zipWith (==) "version") - . lines - hasteCabal ["configure", "--solver", "topdown"] - hasteCabal $ ["build", "--install-jsmods"] ++ ghcOpts - let base = "base-" ++ basever - pkgdb = "--package-db=dist" "package.conf.inplace" - run_ hasteInstHisBinary [base, "dist" "build"] "" - run_ hasteCopyPkgBinary [base, pkgdb] "" - forEachFile "include" $ \f -> cp f (hasteSysDir "include") + hasteCabal Clean [] + hasteCabal Install ["--solver", "topdown", "-finteger-gmp"] -- Install array - inDirectory "array" $ hasteCabal ("install" : ghcOpts) + inDirectory "array" $ hasteCabal Clean [] + inDirectory "array" $ hasteCabal Install [] - -- Install haste-lib - inDirectory "haste-lib" $ hasteCabal ("install" : ghcOpts) + -- Install haste-prim + inDirectory "haste-prim" $ hasteCabal Install [] -- Install time - inDirectory "time" $ hasteCabal ("install" : ghcOpts) + inDirectory "time" $ hasteCabal Install [] + -- Install haste-lib + inDirectory "haste-lib" $ hasteCabal Install [] + -- Export monads-tf; it seems to be hidden by default run_ hastePkgBinary ["expose", "monads-tf"] "" where ghcOpts = concat [ - if tracePrimops cfg then ["--ghc-option=-debug"] else [], - ["--ghc-option=-DHASTE_HOST_WORD_SIZE_IN_BITS=" ++ show hostWordSize] - ] - hasteCabal args = - run_ hasteCabalBinary ("--install-global" : "--unbooted" : args) "" + if tracePrimops cfg then ["--hastec-option=-debug"] else [], + if verbose cfg then ["--verbose"] else []] + configOpts = [ "--with-hastec=" ++ hasteBinary + , "--with-haste-pkg=" ++ hastePkgBinary + , "--libdir=" ++ if os == "darwin" + then pkgSysLibDir + else takeDirectory pkgSysLibDir + , "--package-db=clear" + , "--package-db=global" +#if __GLASGOW_HASKELL__ < 709 + , "--hastec-option=-DHASTE_HOST_WORD_SIZE_IN_BITS=" ++ + show hostWordSize +#endif + ] + hasteCabal Configure args = + withEnv "HASTE_BOOTING" (const "1") $ run_ hasteCabalBinary as "" + where as = "configure" : args ++ ghcOpts ++ configOpts + hasteCabal Install args = + withEnv "HASTE_BOOTING" (const "1") $ run_ hasteCabalBinary as "" + where as = "install" : args ++ ghcOpts ++ configOpts + hasteCabal Build args = + withEnv "HASTE_BOOTING" (const "1") $ run_ hasteCabalBinary as "" + where as = "build" : args ++ ghcOpts + hasteCabal Clean args = + withEnv "HASTE_BOOTING" (const "1") $ run_ hasteCabalBinary as "" + where as = "clean" : args + + vanillaCabal args = run_ "cabal" args "" + + +-- | Copy GHC settings and utils into the given directory. +copyGhcSettings :: FilePath -> Shell () +copyGhcSettings dest = do + cp (libdir "platformConstants") (dest "platformConstants") +#ifdef mingw32_HOST_OS + cp ("settings-ghc-" ++ ghcMajor ++ ".windows") (dest "settings") + cp (libdir "touchy.exe") (dest "touchy.exe") +#else + cp (libdir "settings") (dest "settings") +#endif relocate :: String -> Shell () relocate pkg = run_ hastePkgBinary ["relocate", pkg] "" diff --git a/src/haste-cabal.hs b/src/haste-cabal.hs deleted file mode 100644 --- a/src/haste-cabal.hs +++ /dev/null @@ -1,59 +0,0 @@ --- | haste-cabal - Haste wrapper for cabal. -module Main where -import System.Environment -import System.Exit -import Haste.Environment -import Control.Shell -import Control.Monad (when) -import Data.List - -type Match = (String -> Bool, [String] -> [String]) - -cabal :: [String] -> IO () -cabal args = do - res <- shell $ run_ "cabal" (hasteargs ++ args') "" - case res of - Left _ -> exitFailure - _ -> exitSuccess - where - args' = [arg | arg <- args, arg /= "--install-global", arg /= "--global"] - hasteargs - | "update" `elem` args = - [] - | "build" `elem` args = - ["--with-ghc=" ++ hasteBinary] - | otherwise = - ["--with-compiler=" ++ hasteBinary, - "--with-hc-pkg=" ++ hastePkgBinary, - "--with-hsc2hs=hsc2hs", - "-fhaste-cabal"] ++ - if "--install-global" `elem` args || "--global" `elem` args - then ["--prefix=" ++ hasteCabalSysDir, - "--package-db=" ++ pkgSysDir] - else ["--prefix=" ++ hasteCabalUserDir, - "--package-db=" ++ pkgSysDir, - "--package-db=" ++ pkgUserDir] - - -main :: IO () -main = do - as <- getArgs - when (hasteCabalNeedsReboot && not ("--unbooted" `elem` as)) $ do - putStrLn "WARNING: haste-cabal has not been properly booted." - putStrLn "If you experience problems installing packages, or simply want to" - putStrLn "get rid of this message, please run 'haste-boot'." - - if "update" `elem` as - then do - cabal as - else do - as <- return $ if "--install-jsmods" `elem` as || not ("build" `elem` as) - then libinstall : filter (/= "--install-jsmods") as - else as - as <- return $ if "--unbooted" `elem` as - then unbooted : filter (/= "--unbooted") as - else as - cabal as - where - libinstall = "--ghc-option=--libinstall" - unbooted = "--ghc-option=--unbooted" diff --git a/src/haste-cat.hs b/src/haste-cat.hs --- a/src/haste-cat.hs +++ b/src/haste-cat.hs @@ -1,5 +1,4 @@ - -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, TupleSections #-} module Main where import System.Environment import Haste.Module @@ -18,16 +17,24 @@ else mapM_ printModule as printModule mpkg = do - let (pkg, (_:m)) = break (== ':') mpkg - mods <- mapM (\p -> readModule p pkg m) ("." : libPaths def) - mapM_ printDefs . map fromJust $ filter isJust mods + let (pkg, (_:mn)) = break (== ':') mpkg + paths = "." : libPaths def + mods <- mapM (\p -> (p, ) `fmap` readModule p pkg mn) paths + case filter (isJust . snd) mods of + ((p, Just m):_) -> printDefs p pkg mn m + _ -> return () -printDefs mod = do - mapM_ printDef $ M.toList $ modDefs mod +printDefs :: FilePath -> String -> String -> Module -> IO () +printDefs path pkg mn m = do + putStrLn $ "Package: " ++ pkg + putStrLn $ "Module: " ++ mn + putStrLn $ "Path: " ++ path + putStrLn "---\n" + mapM_ printDef $ M.toList $ modDefs m -printDef (name, def) = do +printDef (name, d) = do BS.putStrLn $ niceName name - BSL.putStrLn $ pretty debugPPOpts def + BSL.putStrLn $ pretty (withPretty . withExtAnnotation $ withAnnotations def) d putStrLn "" niceName (Name n (Just (pkg, m))) = diff --git a/src/haste-copy-pkg.hs b/src/haste-copy-pkg.hs --- a/src/haste-copy-pkg.hs +++ b/src/haste-copy-pkg.hs @@ -58,6 +58,6 @@ isKey key str = and $ zipWith (==) key str - importDir = "${pkgroot}" "libraries" "lib" + importDir = "${pkgroot}" includeDir = "${pkgroot}" "include" pkgRoot = "${pkgroot}" diff --git a/src/hastec.hs b/src/hastec.hs --- a/src/hastec.hs +++ b/src/hastec.hs @@ -2,14 +2,19 @@ -- | Haste's main compiler driver. module Main where import Language.Haskell.GHC.Simple +#if __GLASGOW_HASKELL__ >= 710 +import Language.Haskell.GHC.Simple.PrimIface +#endif import GHC import Outputable (showPpr) -import System.Environment (getArgs) +import System.Environment (getArgs, lookupEnv, setEnv) import System.Exit import Data.List import System.IO.Unsafe import System.IO +import System.FilePath +import System.Directory (copyFile) import Control.Monad import qualified Control.Shell as Sh import qualified Data.ByteString.UTF8 as BS @@ -22,6 +27,7 @@ import Haste.Module import Haste.CodeGen import Haste.Linker +import Haste.JSLib logStr :: Config -> String -> IO () logStr cfg = when (verbose cfg) . hPutStrLn stderr @@ -30,27 +36,55 @@ main = do initUserPkgDB as <- getArgs - let args = "-O2":concat [as,packageDBArgs,["-D__HASTE__="++show intVersion]] - case parseHasteFlags args of + lookupEnv "HASTE_PACKAGE_PATH" >>= setEnv "GHC_PACKAGE_PATH" . maybe "" id + booting <- maybe False (const True) `fmap` lookupEnv "HASTE_BOOTING" + let args = "-O2":concat [pkgs booting, as, ["-D__HASTE__="++show intVersion]] + prof = "-prof" `elem` args + case parseHasteFlags booting args as of Left act -> act Right (fs, mkConfig) -> do let ghcconfig = mkGhcCfg fs args (dfs, _) <- getDynFlagsForConfig ghcconfig let cfg = mkLinkerCfg dfs . setShowOutputable dfs $ mkConfig def - res <- compileFold ghcconfig (compJS cfg) [] [] + res <- compileFold ghcconfig (compJS cfg) ([], []) [] case res of Failure _ _ -> do exitFailure - Success targets _ _ -> do + Success (targets, mods) _ _ -> do when (performLink cfg) $ do - mapM_ (uncurry $ linkAndMinify cfg) targets + if linkJSLib cfg + then buildJSLib prof cfg (fst $ head targets) mods + else mapM_ (uncurry $ linkAndMinify cfg) targets where - compJS cfg targets m = do + dotToSlash '.' = '/' + dotToSlash c = c + + pkgs booting = + ["-no-global-package-db", + "-no-user-package-db", + "-package-db=" ++ pkgSysDir] ++ + if booting && portableHaste + then [] + else ["-package-db=" ++ pkgUserDir] + + buildJSLib profiling cfg pkgkey mods = do + let modpath = targetLibPath cfg ++ "/" ++ pkgkey + mods' = [ modpath ++ "/" ++ map dotToSlash mn ++ ".jsmod" + | mn <- mods] + libfile = maybe (pkgkey <.> "jsmod") id (linkJSLibFile cfg) + profLibfile = reverse (drop 6 (reverse libfile)) ++ "_p.jslib" + + createJSLib libfile (BS.fromString pkgkey) mods' + when profiling . void $ do + copyFile libfile (profLibfile) + + compJS cfg (targets, mods) m = do compJSMod cfg m let infile = maybe (modInterfaceFile m) id (modSourceFile m) + modpair = (modPackageKey m, infile) if modIsTarget m - then return $ (modPackageKey m, infile) : targets - else return targets + then return $ (modpair : targets, modName m : mods) + else return (targets, modName m : mods) mkGhcCfg fs args = defaultConfig { cfgGhcFlags = fs, @@ -61,21 +95,29 @@ ghcLink = NoLink, ghcMode = if "-c" `elem` args then OneShot - else CompManager + else CompManager, + hscTarget = HscAsm } - +#if __GLASGOW_HASKELL__ >= 710 + , cfgCustomPrimIface = Just (primOpInfo, primOpStrictness) +#endif } mkLinkerCfg dfs cfg = cfg { mainMod = Just (pkgKeyString $ modulePkgKey (mainModIs dfs), moduleNameString $ moduleName (mainModIs dfs)) } setShowOutputable dfs cfg = cfg {showOutputable = showPpr dfs} - -- TODO: this breaks sandboxes and must be fixed - packageDBArgs = ["-no-global-package-db", - "-no-user-package-db", - "-package-db " ++ pkgSysDir, - "-package-db " ++ pkgUserDir ] +#if __GLASGOW_HASKELL__ >= 710 +-- | Primop info for custom GHC.Prim interface. +primOpInfo :: PrimOp -> PrimOpInfo +#include "primop-info-710.hs" + +-- | Strictness info for custom GHC.Prim interface. +primOpStrictness :: PrimOp -> Arity -> StrictSig +#include "primop-stricts-710.hs" +#endif + -- | Compile an STG module into a JS module and write it to its appropriate -- location according to the given config. compJSMod :: Config -> StgModule -> IO () @@ -139,10 +181,18 @@ -- | Call vanilla GHC; used for C files and the like. callVanillaGHC :: [String] -> IO () callVanillaGHC args = do - _ <- Sh.shell $ Sh.run_ ghcBinary ghcArgs "" + booting <- maybe False (const True) `fmap` lookupEnv "HASTE_BOOTING" + _ <- Sh.shell $ Sh.run_ ghcBinary (pkgargs booting ++ ghcArgs) "" return () where - Right (_, ghcArgs) = parseArgs (hasteOpts False) "" args + Right (_, ghcArgs) = parseArgs hasteOpts "" args + pkgargs booting = + ["-no-global-package-db", + "-no-user-package-db", + "-package-db=" ++ pkgSysDir] ++ + if booting && portableHaste + then [] + else ["-package-db=" ++ pkgUserDir] -- | Initialize the Haste package database, unless it already exists. initUserPkgDB :: IO () @@ -155,26 +205,27 @@ return () type Message = String -data BootMode = Booted | Unbooted deriving (Show, Eq) -data Compiler = Haste BootMode | GHC deriving (Show, Eq) +data Compiler = Haste | GHC | InstallJSExe | BuildRunner deriving (Show, Eq) data RunMode = Run !Compiler | DontRun !Message deriving (Show, Eq) rebootMsg :: Message rebootMsg = "Haste needs to be rebooted; please run haste-boot" -- | How should we run the compiler for this command line? -runMode :: [String] -> RunMode -runMode args - | "--help" `elem` args = Run (Haste Booted) - | "--info" `elem` args = DontRun ghcInfo - | "--print-libdir" `elem` args = DontRun hasteGhcLibDir - | "--version" `elem` args = DontRun $ showVersion hasteVersion - | "--numeric-version" `elem` args = DontRun $ showVersion ghcVersion - | "--supported-extensions" `elem` args = DontRun exts - | "--supported-languages" `elem` args = DontRun exts - | "--unbooted" `elem` args = Run (chooseCompilerFor args Unbooted) - | hasteNeedsReboot = DontRun rebootMsg - | otherwise = Run (chooseCompilerFor args Booted) +runMode :: Bool -> [String] -> RunMode +runMode booting as + | "--help" `elem` as = Run Haste + | "--install-executable" `elem` as = Run InstallJSExe + | "--build-runner" `elem` as = Run BuildRunner + | "--info" `elem` as = DontRun ghcInfo + | "--print-libdir" `elem` as = DontRun hasteGhcLibDir + | "--print-global-package-db" `elem` as = DontRun pkgSysDir + | "--version" `elem` as = DontRun $ showVersion hasteVersion + | "--numeric-ghc-version" `elem` as = DontRun $ showVersion ghcVersion + | "--supported-extensions" `elem` as = DontRun exts + | "--supported-languages" `elem` as = DontRun exts + | hasteNeedsReboot && not booting = DontRun rebootMsg + | otherwise = Run (chooseCompilerFor as) where exts = unlines supportedLanguagesAndExtensions ghcInfo = unsafePerformIO $ do @@ -184,20 +235,41 @@ -- | Parse Haste and static GHC flags, returning either an action to be taken -- before promptly exiting, or a Haste config and a list of flags for GHC. -parseHasteFlags :: [String] -> Either (IO ()) ([String], Config -> Config) -parseHasteFlags args = do - case runMode args of +parseHasteFlags :: Bool -> [String] -> [String] + -> Either (IO ()) ([String], Config->Config) +parseHasteFlags booting args rawargs = do + case runMode booting args of DontRun msg -> Left $ putStrLn msg Run GHC -> Left $ callVanillaGHC args - Run (Haste bm) -> do - case parseArgs (hasteOpts $ bm == Unbooted) helpHeader args of + Run Haste -> do + case parseArgs hasteOpts helpHeader args of Left msg -> Left $ putStrLn msg Right (cfg, rest) -> Right (filter (/= "-prof") rest, cfg) + Run InstallJSExe -> do + Left $ installJSExe (jsexeIn args) (jsexeOut args) + Run BuildRunner -> do + Left $ callVanillaGHC (rawargs ++ ["-package-id", "Cabal-1.23.0.0-f701f4ea98ec7bed5883c4df743045e6"]) + where + jsexeIn ("--install-executable":exe:_) = exe + jsexeIn (_:xs) = jsexeIn xs + jsexeIn _ = error "No executable to install!" + jsexeOut ("-o":out:_) = out + jsexeOut (_:xs) = jsexeOut xs + jsexeOut _ = error "No executable install target!" + +-- | Install executable as an HTML file. +installJSExe :: FilePath -> FilePath -> IO () +installJSExe inf outf = do + js <- readFile inf + if (take 2 js == " BootMode -> Compiler -chooseCompilerFor args bm - | all hasteOK args = Haste bm +chooseCompilerFor :: [String] -> Compiler +chooseCompilerFor args + | all hasteOK args = Haste | otherwise = GHC where - hasteOK f = not $ any (`isSuffixOf` f) [".c",".cmm",".cc"] + hasteOK f = not $ any (`isSuffixOf` f) [".c",".cmm",".cc",".dyn_o"] diff --git a/utils/haste-pkg/HastePkg708.hs b/utils/haste-pkg/HastePkg708.hs new file mode 100644 --- /dev/null +++ b/utils/haste-pkg/HastePkg708.hs @@ -0,0 +1,1834 @@ +{-# LANGUAGE PatternGuards, CPP, ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2004-2009. +-- +-- Package management tool +-- +----------------------------------------------------------------------------- + +module HastePkg708 (main) where + +import Distribution.InstalledPackageInfo.Binary() +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.ModuleName hiding (main) +import Distribution.InstalledPackageInfo +import Distribution.Compat.ReadP +import Distribution.ParseUtils +import Distribution.Package hiding (depends) +import Distribution.Text +import Distribution.Version +import System.FilePath as FilePath +import qualified System.FilePath.Posix as FilePath.Posix +import System.Process +import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing, + getModificationTime ) +import Text.Printf + +import Prelude + +import System.Console.GetOpt +import qualified Control.Exception as Exception +import Data.Maybe + +import Data.Char ( isSpace, toLower ) +import Data.Ord (comparing) +import Control.Applicative (Applicative(..)) +import Control.Monad +import System.Directory ( doesDirectoryExist, getDirectoryContents, + doesFileExist, renameFile, removeFile, + getCurrentDirectory ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.Environment ( getArgs, getProgName, getEnv ) +import System.IO +import System.IO.Error +import Data.List +import Control.Concurrent + +import qualified Data.ByteString.Lazy as B +import qualified Data.Binary as Bin +import qualified Data.Binary.Get as Bin + +-- Haste-specific +import Haste.Environment +import Haste.Version +import System.Info (os) +import qualified Control.Shell as Sh + +#if defined(mingw32_HOST_OS) +-- mingw32 needs these for getExecDir +import Foreign +import Foreign.C +#endif + +#ifdef mingw32_HOST_OS +import GHC.ConsoleHandler +#else +import System.Posix hiding (fdToHandle) +#endif + +#if defined(GLOB) +import qualified System.Info(os) +#endif + +#if !defined(mingw32_HOST_OS) && !defined(BOOTSTRAPPING) +import System.Console.Terminfo as Terminfo +#endif + +#ifdef mingw32_HOST_OS +# if defined(i386_HOST_ARCH) +# define WINDOWS_CCONV stdcall +# elif defined(x86_64_HOST_ARCH) +# define WINDOWS_CCONV ccall +# else +# error Unknown mingw32 arch +# endif +#endif + +-- ----------------------------------------------------------------------------- +-- Entry point + +main :: IO () +main = do + args <- getArgs + + case args of + ["relocate", pkg] -> do + Sh.shell (relocate packages pkg) >> exitWith ExitSuccess + _ -> + return () + + case getOpt Permute (flags ++ deprecFlags) args of + (cli,_,[]) | FlagHelp `elem` cli -> do + prog <- getProgramName + bye (usageInfo (usageHeader prog) flags) + (cli,_,[]) | FlagVersion `elem` cli -> + bye ourCopyright + (cli,_,[]) | FlagNumericVersion `elem` cli -> + bye $ showVersion hasteVersion ++ "\n" + (cli,_,[]) | FlagNumericGhcVersion `elem` cli -> + bye $ showVersion ghcVersion ++ "\n" + (cli,nonopts,[]) -> + case getVerbosity Normal cli of + Right v -> runit v cli nonopts + Left err -> die err + (_,_,errors) -> do + prog <- getProgramName + die (concat errors ++ shortUsage prog) + where + packages = ["--global-package-db=" ++ pkgSysDir, + "--package-db=" ++ pkgSysDir, + "--package-db=" ++ pkgUserDir] + +-- ----------------------------------------------------------------------------- +-- Command-line syntax + +data Flag + = FlagUser + | FlagGlobal + | FlagHelp + | FlagVersion + | FlagNumericVersion + | FlagNumericGhcVersion + | FlagConfig FilePath + | FlagGlobalConfig FilePath + | FlagForce + | FlagForceFiles + | FlagAutoGHCiLibs + | FlagExpandEnvVars + | FlagExpandPkgroot + | FlagNoExpandPkgroot + | FlagSimpleOutput + | FlagNamesOnly + | FlagIgnoreCase + | FlagNoUserDb + | FlagVerbosity (Maybe String) + deriving Eq + +flags :: [OptDescr Flag] +flags = [ + Option [] ["user"] (NoArg FlagUser) + "use the current user's package database", + Option [] ["global"] (NoArg FlagGlobal) + "use the global package database", + Option ['f'] ["package-db"] (ReqArg FlagConfig "FILE/DIR") + "use the specified package database", + Option [] ["package-conf"] (ReqArg FlagConfig "FILE/DIR") + "use the specified package database (DEPRECATED)", + Option [] ["global-package-db"] (ReqArg FlagGlobalConfig "DIR") + "location of the global package database", + Option [] ["no-user-package-db"] (NoArg FlagNoUserDb) + "never read the user package database", + Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb) + "never read the user package database (DEPRECATED)", + Option [] ["force"] (NoArg FlagForce) + "ignore missing dependencies, directories, and libraries", + Option [] ["force-files"] (NoArg FlagForceFiles) + "ignore missing directories and libraries only", + Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs) + "automatically build libs for GHCi (with register)", + Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars) + "expand environment variables (${name}-style) in input package descriptions", + Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot) + "expand ${pkgroot}-relative paths to absolute in output package descriptions", + Option [] ["no-expand-pkgroot"] (NoArg FlagNoExpandPkgroot) + "preserve ${pkgroot}-relative paths in output package descriptions", + Option ['?'] ["help"] (NoArg FlagHelp) + "display this help and exit", + Option ['V'] ["version"] (NoArg FlagVersion) + "output version information and exit", + Option [] ["numeric-version"] (NoArg FlagNumericVersion) + "output version number and exit", + Option [] ["numeric-ghc-version"] (NoArg FlagNumericGhcVersion) + "output GHC version number and exit", + Option [] ["simple-output"] (NoArg FlagSimpleOutput) + "print output in easy-to-parse format for some commands", + Option [] ["names-only"] (NoArg FlagNamesOnly) + "only print package names, not versions; can only be used with list --simple-output", + Option [] ["ignore-case"] (NoArg FlagIgnoreCase) + "ignore case for substring matching", + Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity") + "verbosity level (0-2, default 1)" + ] + +data Verbosity = Silent | Normal | Verbose + deriving (Show, Eq, Ord) + +getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity +getVerbosity v [] = Right v +getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs +getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs +getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs +getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs +getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v) +getVerbosity v (_ : fs) = getVerbosity v fs + +deprecFlags :: [OptDescr Flag] +deprecFlags = [ + -- put deprecated flags here + ] + +ourCopyright :: String +ourCopyright = "Haste package manager version " ++ showVersion hasteVersion ++ "\n" + +shortUsage :: String -> String +shortUsage prog = "For usage information see '" ++ prog ++ " --help'." + +usageHeader :: String -> String +usageHeader prog = substProg prog $ + "Usage:\n" ++ + " $p init {path}\n" ++ + " Create and initialise a package database at the location {path}.\n" ++ + " Packages can be registered in the new database using the register\n" ++ + " command with --package-db={path}. To use the new database with GHC,\n" ++ + " use GHC's -package-db flag.\n" ++ + "\n" ++ + " $p register {filename | -}\n" ++ + " Register the package using the specified installed package\n" ++ + " description. The syntax for the latter is given in the $p\n" ++ + " documentation. The input file should be encoded in UTF-8.\n" ++ + "\n" ++ + " $p update {filename | -}\n" ++ + " Register the package, overwriting any other package with the\n" ++ + " same name. The input file should be encoded in UTF-8.\n" ++ + "\n" ++ + " $p unregister {pkg-id}\n" ++ + " Unregister the specified package.\n" ++ + "\n" ++ + " $p expose {pkg-id}\n" ++ + " Expose the specified package.\n" ++ + "\n" ++ + " $p hide {pkg-id}\n" ++ + " Hide the specified package.\n" ++ + "\n" ++ + " $p trust {pkg-id}\n" ++ + " Trust the specified package.\n" ++ + "\n" ++ + " $p distrust {pkg-id}\n" ++ + " Distrust the specified package.\n" ++ + "\n" ++ + " $p list [pkg]\n" ++ + " List registered packages in the global database, and also the\n" ++ + " user database if --user is given. If a package name is given\n" ++ + " all the registered versions will be listed in ascending order.\n" ++ + " Accepts the --simple-output flag.\n" ++ + "\n" ++ + " $p dot\n" ++ + " Generate a graph of the package dependencies in a form suitable\n" ++ + " for input for the graphviz tools. For example, to generate a PDF" ++ + " of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++ + "\n" ++ + " $p find-module {module}\n" ++ + " List registered packages exposing module {module} in the global\n" ++ + " database, and also the user database if --user is given.\n" ++ + " All the registered versions will be listed in ascending order.\n" ++ + " Accepts the --simple-output flag.\n" ++ + "\n" ++ + " $p latest {pkg-id}\n" ++ + " Prints the highest registered version of a package.\n" ++ + "\n" ++ + " $p check\n" ++ + " Check the consistency of package dependencies and list broken packages.\n" ++ + " Accepts the --simple-output flag.\n" ++ + "\n" ++ + " $p describe {pkg}\n" ++ + " Give the registered description for the specified package. The\n" ++ + " description is returned in precisely the syntax required by $p\n" ++ + " register.\n" ++ + "\n" ++ + " $p field {pkg} {field}\n" ++ + " Extract the specified field of the package description for the\n" ++ + " specified package. Accepts comma-separated multiple fields.\n" ++ + "\n" ++ + " $p dump\n" ++ + " Dump the registered description for every package. This is like\n" ++ + " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++ + " by tools that parse the results, rather than humans. The output is\n" ++ + " always encoded in UTF-8, regardless of the current locale.\n" ++ + "\n" ++ + " $p recache\n" ++ + " Regenerate the package database cache. This command should only be\n" ++ + " necessary if you added a package to the database by dropping a file\n" ++ + " into the database directory manually. By default, the global DB\n" ++ + " is recached; to recache a different DB use --user or --package-db\n" ++ + " as appropriate.\n" ++ + "\n" ++ + " Substring matching is supported for {module} in find-module and\n" ++ + " for {pkg} in list, describe, and field, where a '*' indicates\n" ++ + " open substring ends (prefix*, *suffix, *infix*).\n" ++ + "\n" ++ + " When asked to modify a database (register, unregister, update,\n"++ + " hide, expose, and also check), ghc-pkg modifies the global database by\n"++ + " default. Specifying --user causes it to act on the user database,\n"++ + " or --package-db can be used to act on another database\n"++ + " entirely. When multiple of these options are given, the rightmost\n"++ + " one is used as the database to act upon.\n"++ + "\n"++ + " Commands that query the package database (list, tree, latest, describe,\n"++ + " field) operate on the list of databases specified by the flags\n"++ + " --user, --global, and --package-db. If none of these flags are\n"++ + " given, the default is --global --user.\n"++ + "\n" ++ + " The following optional flags are also accepted:\n" + +substProg :: String -> String -> String +substProg _ [] = [] +substProg prog ('$':'p':xs) = prog ++ substProg prog xs +substProg prog (c:xs) = c : substProg prog xs + +-- ----------------------------------------------------------------------------- +-- Do the business + +data Force = NoForce | ForceFiles | ForceAll | CannotForce + deriving (Eq,Ord) + +data PackageArg = Id PackageIdentifier | Substring String (String->Bool) + +runit :: Verbosity -> [Flag] -> [String] -> IO () +runit verbosity cli nonopts = do + installSignalHandlers -- catch ^C and clean up + prog <- getProgramName + let + force + | FlagForce `elem` cli = ForceAll + | FlagForceFiles `elem` cli = ForceFiles + | otherwise = NoForce + auto_ghci_libs = FlagAutoGHCiLibs `elem` cli + expand_env_vars= FlagExpandEnvVars `elem` cli + mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli + where accumExpandPkgroot _ FlagExpandPkgroot = Just True + accumExpandPkgroot _ FlagNoExpandPkgroot = Just False + accumExpandPkgroot x _ = x + + splitFields fields = unfoldr splitComma (',':fields) + where splitComma "" = Nothing + splitComma fs = Just $ break (==',') (tail fs) + + substringCheck :: String -> Maybe (String -> Bool) + substringCheck "" = Nothing + substringCheck "*" = Just (const True) + substringCheck [_] = Nothing + substringCheck (h:t) = + case (h, init t, last t) of + ('*',s,'*') -> Just (isInfixOf (f s) . f) + ('*',_, _ ) -> Just (isSuffixOf (f t) . f) + ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f) + _ -> Nothing + where f | FlagIgnoreCase `elem` cli = map toLower + | otherwise = id +#if defined(GLOB) + glob x | System.Info.os=="mingw32" = do + -- glob echoes its argument, after win32 filename globbing + (_,o,_,_) <- runInteractiveCommand ("glob "++x) + txt <- hGetContents o + return (read txt) + glob x | otherwise = return [x] +#endif + -- + -- first, parse the command + case nonopts of +#if defined(GLOB) + -- dummy command to demonstrate usage and permit testing + -- without messing things up; use glob to selectively enable + -- windows filename globbing for file parameters + -- register, update, FlagGlobalConfig, FlagConfig; others? + ["glob", filename] -> do + print filename + glob filename >>= print +#endif + ["init", filename] -> + initPackageDB filename verbosity cli + ["register", filename] -> + registerPackage filename verbosity cli + auto_ghci_libs expand_env_vars False force + ["update", filename] -> + registerPackage filename verbosity cli + auto_ghci_libs expand_env_vars True force + ["unregister", pkgid_str] -> do + pkgid <- readGlobPkgId pkgid_str + unregisterPackage pkgid verbosity cli force + ["expose", pkgid_str] -> do + pkgid <- readGlobPkgId pkgid_str + exposePackage pkgid verbosity cli force + ["hide", pkgid_str] -> do + pkgid <- readGlobPkgId pkgid_str + hidePackage pkgid verbosity cli force + ["trust", pkgid_str] -> do + pkgid <- readGlobPkgId pkgid_str + trustPackage pkgid verbosity cli force + ["distrust", pkgid_str] -> do + pkgid <- readGlobPkgId pkgid_str + distrustPackage pkgid verbosity cli force + ["list"] -> do + listPackages verbosity cli Nothing Nothing + ["list", pkgid_str] -> + case substringCheck pkgid_str of + Nothing -> do pkgid <- readGlobPkgId pkgid_str + listPackages verbosity cli (Just (Id pkgid)) Nothing + Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing + ["dot"] -> do + showPackageDot verbosity cli + ["find-module", moduleName] -> do + let match = maybe (==moduleName) id (substringCheck moduleName) + listPackages verbosity cli Nothing (Just match) + ["latest", pkgid_str] -> do + pkgid <- readGlobPkgId pkgid_str + latestPackage verbosity cli pkgid + ["describe", pkgid_str] -> do + pkgarg <- case substringCheck pkgid_str of + Nothing -> liftM Id (readGlobPkgId pkgid_str) + Just m -> return (Substring pkgid_str m) + describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot) + + ["field", pkgid_str, fields] -> do + pkgarg <- case substringCheck pkgid_str of + Nothing -> liftM Id (readGlobPkgId pkgid_str) + Just m -> return (Substring pkgid_str m) + describeField verbosity cli pkgarg + (splitFields fields) (fromMaybe True mexpand_pkgroot) + + ["check"] -> do + checkConsistency verbosity cli + + ["dump"] -> do + dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot) + + ["recache"] -> do + recache verbosity cli + + [] -> do + die ("missing command\n" ++ shortUsage prog) + (_cmd:_) -> do + die ("command-line syntax error\n" ++ shortUsage prog) + +parseCheck :: ReadP a a -> String -> String -> IO a +parseCheck parser str what = + case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of + [x] -> return x + _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what) + +readGlobPkgId :: String -> IO PackageIdentifier +readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier" + +parseGlobPackageId :: ReadP r PackageIdentifier +parseGlobPackageId = + parse + +++ + (do n <- parse + _ <- string "-*" + return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion })) + +-- globVersion means "all versions" +globVersion :: Version +globVersion = Version{ versionBranch=[], versionTags=["*"] } + +-- ----------------------------------------------------------------------------- +-- Package databases + +-- Some commands operate on a single database: +-- register, unregister, expose, hide, trust, distrust +-- however these commands also check the union of the available databases +-- in order to check consistency. For example, register will check that +-- dependencies exist before registering a package. +-- +-- Some commands operate on multiple databases, with overlapping semantics: +-- list, describe, field + +data PackageDB + = PackageDB { + location, locationAbsolute :: !FilePath, + -- We need both possibly-relative and definately-absolute package + -- db locations. This is because the relative location is used as + -- an identifier for the db, so it is important we do not modify it. + -- On the other hand we need the absolute path in a few places + -- particularly in relation to the ${pkgroot} stuff. + + packages :: [InstalledPackageInfo] + } + +type PackageDBStack = [PackageDB] + -- A stack of package databases. Convention: head is the topmost + -- in the stack. + +allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo] +allPackagesInStack = concatMap packages + +getPkgDatabases :: Verbosity + -> Bool -- we are modifying, not reading + -> Bool -- read caches, if available + -> Bool -- expand vars, like ${pkgroot} and $topdir + -> [Flag] + -> IO (PackageDBStack, + -- the real package DB stack: [global,user] ++ + -- DBs specified on the command line with -f. + Maybe FilePath, + -- which one to modify, if any + PackageDBStack) + -- the package DBs specified on the command + -- line, or [global,user] otherwise. This + -- is used as the list of package DBs for + -- commands that just read the DB, such as 'list'. + +getPkgDatabases verbosity modify use_cache expand_vars my_flags = do + -- first we determine the location of the global package config. On Windows, + -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the + -- location is passed to the binary using the --global-package-db flag by the + -- wrapper script. + let err_msg = "missing --global-package-db option, location of global package database unknown\n" + global_conf <- + case [ f | FlagGlobalConfig f <- my_flags ] of + [] -> do mb_dir <- getLibDir + case mb_dir of + Nothing -> die err_msg + Just dir -> do + r <- lookForPackageDBIn dir + case r of + Nothing -> die ("Can't find package database in " ++ dir) + Just path -> return path + fs -> return (last fs) + + -- The value of the $topdir variable used in some package descriptions + -- Note that the way we calculate this is slightly different to how it + -- is done in ghc itself. We rely on the convention that the global + -- package db lives in ghc's libdir. + top_dir <- absolutePath (takeDirectory global_conf) + + let no_user_db = FlagNoUserDb `elem` my_flags + + mb_user_conf <- + if no_user_db then return Nothing else do + r <- lookForPackageDBIn hasteUserDir + case r of + Nothing -> return (Just (pkgUserDir, False)) + Just f -> return (Just (f, True)) + + -- If the user database doesn't exist, and this command isn't a + -- "modify" command, then we won't attempt to create or use it. + let sys_databases + | Just (user_conf,user_exists) <- mb_user_conf, + modify || user_exists = [user_conf, global_conf] + | otherwise = [global_conf] + + e_pkg_path <- tryIO (System.Environment.getEnv "HASTE_PACKAGE_PATH") + let env_stack = + case e_pkg_path of + Left _ -> sys_databases + Right path + | last cs == "" -> init cs ++ sys_databases + | otherwise -> cs + where cs = parseSearchPath path + + -- The "global" database is always the one at the bottom of the stack. + -- This is the database we modify by default. + virt_global_conf = last env_stack + + let db_flags = [ f | Just f <- map is_db_flag my_flags ] + where is_db_flag FlagUser + | Just (user_conf, _user_exists) <- mb_user_conf + = Just user_conf + is_db_flag FlagGlobal = Just virt_global_conf + is_db_flag (FlagConfig f) = Just f + is_db_flag _ = Nothing + + let flag_db_names | null db_flags = env_stack + | otherwise = reverse (nub db_flags) + + -- For a "modify" command, treat all the databases as + -- a stack, where we are modifying the top one, but it + -- can refer to packages in databases further down the + -- stack. + + -- -f flags on the command line add to the database + -- stack, unless any of them are present in the stack + -- already. + let final_stack = filter (`notElem` env_stack) + [ f | FlagConfig f <- reverse my_flags ] + ++ env_stack + + -- the database we actually modify is the one mentioned + -- rightmost on the command-line. + let to_modify + | not modify = Nothing + | null db_flags = Just virt_global_conf + | otherwise = Just (last db_flags) + + db_stack <- sequence + [ do db <- readParseDatabase verbosity mb_user_conf use_cache db_path + if expand_vars then return (mungePackageDBPaths top_dir db) + else return db + | db_path <- final_stack ] + + let flag_db_stack = [ db | db_name <- flag_db_names, + db <- db_stack, location db == db_name ] + + return (db_stack, to_modify, flag_db_stack) + + +lookForPackageDBIn :: FilePath -> IO (Maybe FilePath) +lookForPackageDBIn dir = do + let path_dir = dir "package.conf.d" + exists_dir <- doesDirectoryExist path_dir + if exists_dir then return (Just path_dir) else do + let path_file = dir "package.conf" + exists_file <- doesFileExist path_file + if exists_file then return (Just path_file) else return Nothing + +readParseDatabase :: Verbosity + -> Maybe (FilePath,Bool) + -> Bool -- use cache + -> FilePath + -> IO PackageDB + +readParseDatabase verbosity mb_user_conf use_cache path + -- the user database (only) is allowed to be non-existent + | Just (user_conf,False) <- mb_user_conf, path == user_conf + = mkPackageDB [] + | otherwise + = do e <- tryIO $ getDirectoryContents path + case e of + Left _ -> do + pkgs <- parseMultiPackageConf verbosity path + mkPackageDB pkgs + Right fs + | not use_cache -> ignore_cache (const $ return ()) + | otherwise -> do + let cache = path cachefilename + tdir <- getModificationTime path + e_tcache <- tryIO $ getModificationTime cache + case e_tcache of + Left ex -> do + when (verbosity > Normal) $ + warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex) + ignore_cache (const $ return ()) + Right tcache -> do + let compareTimestampToCache file = + when (verbosity >= Verbose) $ do + tFile <- getModificationTime file + compareTimestampToCache' file tFile + compareTimestampToCache' file tFile = do + let rel = case tcache `compare` tFile of + LT -> " (NEWER than cache)" + GT -> " (older than cache)" + EQ -> " (same as cache)" + warn ("Timestamp " ++ show tFile + ++ " for " ++ file ++ rel) + when (verbosity >= Verbose) $ do + warn ("Timestamp " ++ show tcache ++ " for " ++ cache) + compareTimestampToCache' path tdir + if tcache >= tdir + then do + when (verbosity > Normal) $ + infoLn ("using cache: " ++ cache) + pkgs <- myReadBinPackageDB cache + let pkgs' = map convertPackageInfoIn pkgs + mkPackageDB pkgs' + else do + when (verbosity >= Normal) $ do + warn ("WARNING: cache is out of date: " + ++ cache) + warn "Use 'ghc-pkg recache' to fix." + ignore_cache compareTimestampToCache + where + ignore_cache :: (FilePath -> IO ()) -> IO PackageDB + ignore_cache checkTime = do + let confs = filter (".conf" `isSuffixOf`) fs + doFile f = do checkTime f + parseSingletonPackageConf verbosity f + pkgs <- mapM doFile $ map (path ) confs + mkPackageDB pkgs + where + mkPackageDB pkgs = do + path_abs <- absolutePath path + return PackageDB { + location = path, + locationAbsolute = path_abs, + packages = pkgs + } + +-- read the package.cache file strictly, to work around a problem with +-- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed +-- after it has been completely read, leading to a sharing violation +-- later. +myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString] +myReadBinPackageDB filepath = do + h <- openBinaryFile filepath ReadMode + sz <- hFileSize h + b <- B.hGet h (fromIntegral sz) + hClose h + return $ Bin.runGet Bin.get b + +parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo] +parseMultiPackageConf verbosity file = do + when (verbosity > Normal) $ infoLn ("reading package database: " ++ file) + str <- readUTF8File file + let pkgs = map convertPackageInfoIn $ read str + Exception.evaluate pkgs + `catchError` \e-> + die ("error while parsing " ++ file ++ ": " ++ show e) + +parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo +parseSingletonPackageConf verbosity file = do + when (verbosity > Normal) $ infoLn ("reading package config: " ++ file) + readUTF8File file >>= fmap fst . parsePackageInfo + +cachefilename :: FilePath +cachefilename = "package.cache" + +mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB +mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } = + db { packages = map (mungePackagePaths top_dir pkgroot) pkgs } + where + pkgroot = takeDirectory (locationAbsolute db) + -- It so happens that for both styles of package db ("package.conf" + -- files and "package.conf.d" dirs) the pkgroot is the parent directory + -- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/ + +-- TODO: This code is duplicated in compiler/main/Packages.lhs +mungePackagePaths :: FilePath -> FilePath + -> InstalledPackageInfo -> InstalledPackageInfo +-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec +-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) +-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. +-- The "pkgroot" is the directory containing the package database. +-- +-- Also perform a similar substitution for the older GHC-specific +-- "$topdir" variable. The "topdir" is the location of the ghc +-- installation (obtained from the -B option). +mungePackagePaths top_dir pkgroot pkg = + pkg { + importDirs = munge_paths (importDirs pkg), + includeDirs = munge_paths (includeDirs pkg), + libraryDirs = munge_paths (libraryDirs pkg), + frameworkDirs = munge_paths (frameworkDirs pkg), + haddockInterfaces = munge_paths (haddockInterfaces pkg), + -- haddock-html is allowed to be either a URL or a file + haddockHTMLs = munge_paths (munge_urls (haddockHTMLs pkg)) + } + where + munge_paths = map munge_path + munge_urls = map munge_url + + munge_path p + | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p' + | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p' + | otherwise = p + + munge_url p + | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p' + | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p' + | otherwise = p + + toUrlPath r p = "file:///" + -- URLs always use posix style '/' separators: + ++ FilePath.Posix.joinPath + (r : -- We need to drop a leading "/" or "\\" + -- if there is one: + dropWhile (all isPathSeparator) + (FilePath.splitDirectories p)) + + -- We could drop the separator here, and then use above. However, + -- by leaving it in and using ++ we keep the same path separator + -- rather than letting FilePath change it to use \ as the separator + stripVarPrefix var path = case stripPrefix var path of + Just [] -> Just [] + Just cs@(c : _) | isPathSeparator c -> Just cs + _ -> Nothing + + +-- ----------------------------------------------------------------------------- +-- Creating a new package DB + +initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO () +initPackageDB filename verbosity _flags = do + let eexist = die ("cannot create: " ++ filename ++ " already exists") + b1 <- doesFileExist filename + when b1 eexist + b2 <- doesDirectoryExist filename + when b2 eexist + filename_abs <- absolutePath filename + changeDB verbosity [] PackageDB { + location = filename, locationAbsolute = filename_abs, + packages = [] + } + +-- ----------------------------------------------------------------------------- +-- Registering + +registerPackage :: FilePath + -> Verbosity + -> [Flag] + -> Bool -- auto_ghci_libs + -> Bool -- expand_env_vars + -> Bool -- update + -> Force + -> IO () +registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do + (db_stack, Just to_modify, _flag_dbs) <- + getPkgDatabases verbosity True True False{-expand vars-} my_flags + + let + db_to_operate_on = my_head "register" $ + filter ((== to_modify).location) db_stack + -- + when (auto_ghci_libs && verbosity >= Silent) $ + warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4" + -- + s <- + case input of + "-" -> do + when (verbosity >= Normal) $ + info "Reading package info from stdin ... " + -- fix the encoding to UTF-8, since this is an interchange format + hSetEncoding stdin utf8 + getContents + f -> do + when (verbosity >= Normal) $ + info ("Reading package info from " ++ show f ++ " ... ") + readUTF8File f + + expanded <- if expand_env_vars then expandEnvVars s force + else return s + + (pkg, ws) <- parsePackageInfo expanded + when (verbosity >= Normal) $ + infoLn "done." + + -- report any warnings from the parse phase + _ <- reportValidateErrors [] ws + (display (sourcePackageId pkg) ++ ": Warning: ") Nothing + + -- validate the expanded pkg, but register the unexpanded + pkgroot <- absolutePath (takeDirectory to_modify) + let top_dir = takeDirectory (location (last db_stack)) + pkg_expanded = mungePackagePaths top_dir pkgroot pkg + + let truncated_stack = dropWhile ((/= to_modify).location) db_stack + -- truncate the stack for validation, because we don't allow + -- packages lower in the stack to refer to those higher up. + validatePackageConfig pkg_expanded verbosity truncated_stack auto_ghci_libs update force + let + removes = [ RemovePackage p + | p <- packages db_to_operate_on, + sourcePackageId p == sourcePackageId pkg ] + -- + changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on + +parsePackageInfo + :: String + -> IO (InstalledPackageInfo, [ValidateWarning]) +parsePackageInfo str = + case parseInstalledPackageInfo str of + ParseOk warnings ok -> return (ok, ws) + where + ws = [ msg | PWarning msg <- warnings + , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ] + ParseFailed err -> case locatedErrorMsg err of + (Nothing, s) -> die s + (Just l, s) -> die (show l ++ ": " ++ s) + +-- ----------------------------------------------------------------------------- +-- Making changes to a package database + +data DBOp = RemovePackage InstalledPackageInfo + | AddPackage InstalledPackageInfo + | ModifyPackage InstalledPackageInfo + +changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO () +changeDB verbosity cmds db = do + let db' = updateInternalDB db cmds + isfile <- doesFileExist (location db) + if isfile + then writeNewConfig verbosity (location db') (packages db') + else do + createDirectoryIfMissing True (location db) + changeDBDir verbosity cmds db' + +updateInternalDB :: PackageDB -> [DBOp] -> PackageDB +updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds } + where + do_cmd pkgs (RemovePackage p) = + filter ((/= installedPackageId p) . installedPackageId) pkgs + do_cmd pkgs (AddPackage p) = p : pkgs + do_cmd pkgs (ModifyPackage p) = + do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p) + + +changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO () +changeDBDir verbosity cmds db = do + mapM_ do_cmd cmds + updateDBCache verbosity db + where + do_cmd (RemovePackage p) = do + let file = location db display (installedPackageId p) <.> "conf" + when (verbosity > Normal) $ infoLn ("removing " ++ file) + removeFileSafe file + do_cmd (AddPackage p) = do + let file = location db display (installedPackageId p) <.> "conf" + when (verbosity > Normal) $ infoLn ("writing " ++ file) + writeFileUtf8Atomic file (showInstalledPackageInfo p) + do_cmd (ModifyPackage p) = + do_cmd (AddPackage p) + +updateDBCache :: Verbosity -> PackageDB -> IO () +updateDBCache verbosity db = do + let filename = location db cachefilename + when (verbosity > Normal) $ + infoLn ("writing cache " ++ filename) + writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db)) + `catchIO` \e -> + if isPermissionError e + then die (filename ++ ": you don't have permission to modify this file") + else ioError e +#ifndef mingw32_HOST_OS + status <- getFileStatus filename + setFileTimes (location db) (accessTime status) (modificationTime status) +#endif + +-- ----------------------------------------------------------------------------- +-- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar + +exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () +exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True}) + +hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () +hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False}) + +trustPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () +trustPackage = modifyPackage (\p -> ModifyPackage p{trusted=True}) + +distrustPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () +distrustPackage = modifyPackage (\p -> ModifyPackage p{trusted=False}) + +unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () +unregisterPackage = modifyPackage RemovePackage + +modifyPackage + :: (InstalledPackageInfo -> DBOp) + -> PackageIdentifier + -> Verbosity + -> [Flag] + -> Force + -> IO () +modifyPackage fn pkgid verbosity my_flags force = do + (db_stack, Just _to_modify, _flag_dbs) <- + getPkgDatabases verbosity True{-modify-} True{-use cache-} False{-expand vars-} my_flags + + (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid) + let + db_name = location db + pkgs = packages db + + pids = map sourcePackageId ps + + cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ] + new_db = updateInternalDB db cmds + + old_broken = brokenPackages (allPackagesInStack db_stack) + rest_of_stack = filter ((/= db_name) . location) db_stack + new_stack = new_db : rest_of_stack + new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack)) + newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken + -- + when (not (null newly_broken)) $ + dieOrForceAll force ("unregistering " ++ display pkgid ++ + " would break the following packages: " + ++ unwords (map display newly_broken)) + + changeDB verbosity cmds db + +recache :: Verbosity -> [Flag] -> IO () +recache verbosity my_flags = do + (db_stack, Just to_modify, _flag_dbs) <- + getPkgDatabases verbosity True{-modify-} False{-no cache-} False{-expand vars-} my_flags + let + db_to_operate_on = my_head "recache" $ + filter ((== to_modify).location) db_stack + -- + changeDB verbosity [] db_to_operate_on + +-- ----------------------------------------------------------------------------- +-- Listing packages + +listPackages :: Verbosity -> [Flag] -> Maybe PackageArg + -> Maybe (String->Bool) + -> IO () +listPackages verbosity my_flags mPackageName mModuleName = do + let simple_output = FlagSimpleOutput `elem` my_flags + (db_stack, _, flag_db_stack) <- + getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags + + let db_stack_filtered -- if a package is given, filter out all other packages + | Just this <- mPackageName = + [ db{ packages = filter (this `matchesPkg`) (packages db) } + | db <- flag_db_stack ] + | Just match <- mModuleName = -- packages which expose mModuleName + [ db{ packages = filter (match `exposedInPkg`) (packages db) } + | db <- flag_db_stack ] + | otherwise = flag_db_stack + + db_stack_sorted + = [ db{ packages = sort_pkgs (packages db) } + | db <- db_stack_filtered ] + where sort_pkgs = sortBy cmpPkgIds + cmpPkgIds pkg1 pkg2 = + case pkgName p1 `compare` pkgName p2 of + LT -> LT + GT -> GT + EQ -> pkgVersion p1 `compare` pkgVersion p2 + where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2) + + stack = reverse db_stack_sorted + + match `exposedInPkg` pkg = any match (map display $ exposedModules pkg) + + pkg_map = allPackagesInStack db_stack + broken = map sourcePackageId (brokenPackages pkg_map) + + show_normal PackageDB{ location = db_name, packages = pkg_confs } = + do hPutStrLn stdout (db_name ++ ":") + if null pp_pkgs + then hPutStrLn stdout " (no packages)" + else hPutStrLn stdout $ unlines (map (" " ++) pp_pkgs) + where + -- Sort using instance Ord PackageId + pp_pkgs = map pp_pkg . sortBy (comparing installedPackageId) $ pkg_confs + pp_pkg p + | sourcePackageId p `elem` broken = printf "{%s}" doc + | exposed p = doc + | otherwise = printf "(%s)" doc + where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid + | otherwise = pkg + where + InstalledPackageId ipid = installedPackageId p + pkg = display (sourcePackageId p) + + show_simple = simplePackageList my_flags . allPackagesInStack + + when (not (null broken) && not simple_output && verbosity /= Silent) $ do + prog <- getProgramName + warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.") + + if simple_output then show_simple stack else do + +#if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING) + mapM_ show_normal stack +#else + let + show_colour withF db = + mconcat $ map (<#> termText "\n") $ + (termText (location db) : + map (termText " " <#>) (map pp_pkg (packages db))) + where + pp_pkg p + | sourcePackageId p `elem` broken = withF Red doc + | exposed p = doc + | otherwise = withF Blue doc + where doc | verbosity >= Verbose + = termText (printf "%s (%s)" pkg ipid) + | otherwise + = termText pkg + where + InstalledPackageId ipid = installedPackageId p + pkg = display (sourcePackageId p) + + is_tty <- hIsTerminalDevice stdout + if not is_tty + then mapM_ show_normal stack + else do tty <- Terminfo.setupTermFromEnv + case Terminfo.getCapability tty withForegroundColor of + Nothing -> mapM_ show_normal stack + Just w -> runTermOutput tty $ mconcat $ + map (show_colour w) stack +#endif + +simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO () +simplePackageList my_flags pkgs = do + let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName + else display + -- Sort using instance Ord PackageId + strs = map showPkg $ sort $ map sourcePackageId pkgs + when (not (null pkgs)) $ + hPutStrLn stdout $ concat $ intersperse " " strs + +showPackageDot :: Verbosity -> [Flag] -> IO () +showPackageDot verbosity myflags = do + (_, _, flag_db_stack) <- + getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} myflags + + let all_pkgs = allPackagesInStack flag_db_stack + ipix = PackageIndex.fromList all_pkgs + + putStrLn "digraph {" + let quote s = '"':s ++ "\"" + mapM_ putStrLn [ quote from ++ " -> " ++ quote to + | p <- all_pkgs, + let from = display (sourcePackageId p), + depid <- depends p, + Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid], + let to = display (sourcePackageId dep) + ] + putStrLn "}" + +-- ----------------------------------------------------------------------------- +-- Prints the highest (hidden or exposed) version of a package + +latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO () +latestPackage verbosity my_flags pkgid = do + (_, _, flag_db_stack) <- + getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags + + ps <- findPackages flag_db_stack (Id pkgid) + case ps of + [] -> die "no matches" + _ -> show_pkg . maximum . map sourcePackageId $ ps + where + show_pkg pid = hPutStrLn stdout (display pid) + +-- ----------------------------------------------------------------------------- +-- Describe + +describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO () +describePackage verbosity my_flags pkgarg expand_pkgroot = do + (_, _, flag_db_stack) <- + getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags + dbs <- findPackagesByDB flag_db_stack pkgarg + doDump expand_pkgroot [ (pkg, locationAbsolute db) + | (db, pkgs) <- dbs, pkg <- pkgs ] + +dumpPackages :: Verbosity -> [Flag] -> Bool -> IO () +dumpPackages verbosity my_flags expand_pkgroot = do + (_, _, flag_db_stack) <- + getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags + doDump expand_pkgroot [ (pkg, locationAbsolute db) + | db <- flag_db_stack, pkg <- packages db ] + +doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO () +doDump expand_pkgroot pkgs = do + -- fix the encoding to UTF-8, since this is an interchange format + hSetEncoding stdout utf8 + putStrLn $ + intercalate "---\n" + [ if expand_pkgroot + then showInstalledPackageInfo pkg + else showInstalledPackageInfo pkg ++ pkgrootField + | (pkg, pkgloc) <- pkgs + , let pkgroot = takeDirectory pkgloc + pkgrootField = "pkgroot: " ++ show pkgroot ++ "\n" ] + +-- PackageId is can have globVersion for the version +findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo] +findPackages db_stack pkgarg + = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg + +findPackagesByDB :: PackageDBStack -> PackageArg + -> IO [(PackageDB, [InstalledPackageInfo])] +findPackagesByDB db_stack pkgarg + = case [ (db, matched) + | db <- db_stack, + let matched = filter (pkgarg `matchesPkg`) (packages db), + not (null matched) ] of + [] -> die ("cannot find package " ++ pkg_msg pkgarg) + ps -> return ps + where + pkg_msg (Id pkgid) = display pkgid + pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat + +matches :: PackageIdentifier -> PackageIdentifier -> Bool +pid `matches` pid' + = (pkgName pid == pkgName pid') + && (pkgVersion pid == pkgVersion pid' || not (realVersion pid)) + +realVersion :: PackageIdentifier -> Bool +realVersion pkgid = versionBranch (pkgVersion pkgid) /= [] + -- when versionBranch == [], this is a glob + +matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool +(Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg +(Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg)) + +-- ----------------------------------------------------------------------------- +-- Field + +describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO () +describeField verbosity my_flags pkgarg fields expand_pkgroot = do + (_, _, flag_db_stack) <- + getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags + fns <- mapM toField fields + ps <- findPackages flag_db_stack pkgarg + mapM_ (selectFields fns) ps + where showFun = if FlagSimpleOutput `elem` my_flags + then showSimpleInstalledPackageInfoField + else showInstalledPackageInfoField + toField f = case showFun f of + Nothing -> die ("unknown field: " ++ f) + Just fn -> return fn + selectFields fns pinfo = mapM_ (\fn->putStrLn (fn pinfo)) fns + + +-- ----------------------------------------------------------------------------- +-- Check: Check consistency of installed packages + +checkConsistency :: Verbosity -> [Flag] -> IO () +checkConsistency verbosity my_flags = do + (db_stack, _, _) <- + getPkgDatabases verbosity True True{-use cache-} True{-expand vars-} my_flags + -- check behaves like modify for the purposes of deciding which + -- databases to use, because ordering is important. + + let simple_output = FlagSimpleOutput `elem` my_flags + + let pkgs = allPackagesInStack db_stack + + checkPackage p = do + (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack False True + if null es + then do when (not simple_output) $ do + _ <- reportValidateErrors [] ws "" Nothing + return () + return [] + else do + when (not simple_output) $ do + reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":") + _ <- reportValidateErrors es ws " " Nothing + return () + return [p] + + broken_pkgs <- concat `fmap` mapM checkPackage pkgs + + let filterOut pkgs1 pkgs2 = filter not_in pkgs2 + where not_in p = sourcePackageId p `notElem` all_ps + all_ps = map sourcePackageId pkgs1 + + let not_broken_pkgs = filterOut broken_pkgs pkgs + (_, trans_broken_pkgs) = closure [] not_broken_pkgs + all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs + + when (not (null all_broken_pkgs)) $ do + if simple_output + then simplePackageList my_flags all_broken_pkgs + else do + reportError ("\nThe following packages are broken, either because they have a problem\n"++ + "listed above, or because they depend on a broken package.") + mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs + + when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1) + + +closure :: [InstalledPackageInfo] -> [InstalledPackageInfo] + -> ([InstalledPackageInfo], [InstalledPackageInfo]) +closure pkgs db_stack = go pkgs db_stack + where + go avail not_avail = + case partition (depsAvailable avail) not_avail of + ([], not_avail') -> (avail, not_avail') + (new_avail, not_avail') -> go (new_avail ++ avail) not_avail' + + depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo + -> Bool + depsAvailable pkgs_ok pkg = null dangling + where dangling = filter (`notElem` pids) (depends pkg) + pids = map installedPackageId pkgs_ok + + -- we want mutually recursive groups of package to show up + -- as broken. (#1750) + +brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo] +brokenPackages pkgs = snd (closure [] pkgs) + +-- ----------------------------------------------------------------------------- +-- Manipulating package.conf files + +type InstalledPackageInfoString = InstalledPackageInfo_ String + +convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString +convertPackageInfoOut + (pkgconf@(InstalledPackageInfo { exposedModules = e, + hiddenModules = h })) = + pkgconf{ exposedModules = map display e, + hiddenModules = map display h } + +convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo +convertPackageInfoIn + (pkgconf@(InstalledPackageInfo { exposedModules = e, + hiddenModules = h })) = + pkgconf{ exposedModules = map convert e, + hiddenModules = map convert h } + where convert = fromJust . simpleParse + +writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO () +writeNewConfig verbosity filename ipis = do + when (verbosity >= Normal) $ + info "Writing new package config file... " + createDirectoryIfMissing True $ takeDirectory filename + let shown = concat $ intersperse ",\n " + $ map (show . convertPackageInfoOut) ipis + fileContents = "[" ++ shown ++ "\n]" + writeFileUtf8Atomic filename fileContents + `catchIO` \e -> + if isPermissionError e + then die (filename ++ ": you don't have permission to modify this file") + else ioError e + when (verbosity >= Normal) $ + infoLn "done." + +----------------------------------------------------------------------------- +-- Sanity-check a new package config, and automatically build GHCi libs +-- if requested. + +type ValidateError = (Force,String) +type ValidateWarning = String + +newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) } + +instance Functor Validate where + fmap = liftM + +instance Applicative Validate where + pure = return + (<*>) = ap + +instance Monad Validate where + return a = V $ return (a, [], []) + m >>= k = V $ do + (a, es, ws) <- runValidate m + (b, es', ws') <- runValidate (k a) + return (b,es++es',ws++ws') + +verror :: Force -> String -> Validate () +verror f s = V (return ((),[(f,s)],[])) + +vwarn :: String -> Validate () +vwarn s = V (return ((),[],["Warning: " ++ s])) + +liftIO :: IO a -> Validate a +liftIO k = V (k >>= \a -> return (a,[],[])) + +-- returns False if we should die +reportValidateErrors :: [ValidateError] -> [ValidateWarning] + -> String -> Maybe Force -> IO Bool +reportValidateErrors es ws prefix mb_force = do + mapM_ (warn . (prefix++)) ws + oks <- mapM report es + return (and oks) + where + report (f,s) + | Just force <- mb_force + = if (force >= f) + then do reportError (prefix ++ s ++ " (ignoring)") + return True + else if f < CannotForce + then do reportError (prefix ++ s ++ " (use --force to override)") + return False + else do reportError err + return False + | otherwise = do reportError err + return False + where + err = prefix ++ s + +validatePackageConfig :: InstalledPackageInfo + -> Verbosity + -> PackageDBStack + -> Bool -- auto-ghc-libs + -> Bool -- update, or check + -> Force + -> IO () +validatePackageConfig pkg verbosity db_stack auto_ghci_libs update force = do + (_,es,ws) <- runValidate $ checkPackageConfig pkg verbosity db_stack auto_ghci_libs update + ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force) + when (not ok) $ exitWith (ExitFailure 1) + +checkPackageConfig :: InstalledPackageInfo + -> Verbosity + -> PackageDBStack + -> Bool -- auto-ghc-libs + -> Bool -- update, or check + -> Validate () +checkPackageConfig pkg verbosity db_stack auto_ghci_libs update = do + checkInstalledPackageId pkg db_stack update + checkPackageId pkg + checkDuplicates db_stack pkg update + mapM_ (checkDep db_stack) (depends pkg) + checkDuplicateDepends (depends pkg) + mapM_ (checkDir False "import-dirs") (importDirs pkg) + mapM_ (checkDir True "library-dirs") (libraryDirs pkg) + mapM_ (checkDir True "include-dirs") (includeDirs pkg) + mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg) + mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg) + mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg) + checkModules pkg + -- TODO: move jsmod directory structure into single jslib file? + -- mapM_ (checkHSLib verbosity (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg) + -- ToDo: check these somehow? + -- extra_libraries :: [String], + -- c_includes :: [String], + +checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool + -> Validate () +checkInstalledPackageId ipi db_stack update = do + let ipid@(InstalledPackageId str) = installedPackageId ipi + when (null str) $ verror CannotForce "missing id field" + let dups = [ p | p <- allPackagesInStack db_stack, + installedPackageId p == ipid ] + when (not update && not (null dups)) $ + verror CannotForce $ + "package(s) with this id already exist: " ++ + unwords (map (display.packageId) dups) + +-- When the package name and version are put together, sometimes we can +-- end up with a package id that cannot be parsed. This will lead to +-- difficulties when the user wants to refer to the package later, so +-- we check that the package id can be parsed properly here. +checkPackageId :: InstalledPackageInfo -> Validate () +checkPackageId ipi = + let str = display (sourcePackageId ipi) in + case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of + [_] -> return () + [] -> verror CannotForce ("invalid package identifier: " ++ str) + _ -> verror CannotForce ("ambiguous package identifier: " ++ str) + +checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate () +checkDuplicates db_stack pkg update = do + let + pkgid = sourcePackageId pkg + pkgs = packages (head db_stack) + -- + -- Check whether this package id already exists in this DB + -- + when (not update && (pkgid `elem` map sourcePackageId pkgs)) $ + verror CannotForce $ + "package " ++ display pkgid ++ " is already installed" + + let + uncasep = map toLower . display + dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs) + + when (not update && not (null dups)) $ verror ForceAll $ + "Package names may be treated case-insensitively in the future.\n"++ + "Package " ++ display pkgid ++ + " overlaps with: " ++ unwords (map display dups) + +checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate () +checkDir = checkPath False True +checkFile = checkPath False False +checkDirURL = checkPath True True + +checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate () +checkPath url_ok is_dir warn_only thisfield d + | url_ok && ("http://" `isPrefixOf` d + || "https://" `isPrefixOf` d) = return () + + | url_ok + , Just d' <- stripPrefix "file://" d + = checkPath False is_dir warn_only thisfield d' + + -- Note: we don't check for $topdir/${pkgroot} here. We rely on these + -- variables having been expanded already, see mungePackagePaths. + + | isRelative d = verror ForceFiles $ + thisfield ++ ": " ++ d ++ " is a relative path which " + ++ "makes no sense (as there is nothing for it to be " + ++ "relative to). You can make paths relative to the " + ++ "package database itself by using ${pkgroot}." + -- relative paths don't make any sense; #4134 + | otherwise = do + there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d + when (not there) $ + let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a " + ++ if is_dir then "directory" else "file" + in + if warn_only + then vwarn msg + else verror ForceFiles msg + +checkDep :: PackageDBStack -> InstalledPackageId -> Validate () +checkDep db_stack pkgid + | pkgid `elem` pkgids = return () + | otherwise = verror ForceAll ("dependency \"" ++ display pkgid + ++ "\" doesn't exist") + where + all_pkgs = allPackagesInStack db_stack + pkgids = map installedPackageId all_pkgs + +checkDuplicateDepends :: [InstalledPackageId] -> Validate () +checkDuplicateDepends deps + | null dups = return () + | otherwise = verror ForceAll ("package has duplicate dependencies: " ++ + unwords (map display dups)) + where + dups = [ p | (p:_:_) <- group (sort deps) ] + +checkHSLib :: Verbosity -> [String] -> Bool -> String -> Validate () +checkHSLib verbosity dirs auto_ghci_libs lib = do + let batch_lib_file = "lib" ++ lib ++ ".a" + filenames = ["lib" ++ lib ++ ".a", + "lib" ++ lib ++ ".p_a", + "lib" ++ lib ++ "-ghc" ++ showVersion ghcVersion ++ ".so", + "lib" ++ lib ++ "-ghc" ++ showVersion ghcVersion ++ ".dylib", + lib ++ "-ghc" ++ showVersion ghcVersion ++ ".dll"] + m <- liftIO $ doesFileExistOnPath filenames dirs + case m of + Nothing -> verror ForceFiles ("cannot find any of " ++ show filenames ++ + " on library path") + Just dir -> liftIO $ checkGHCiLib verbosity dir batch_lib_file lib auto_ghci_libs + +doesFileExistOnPath :: [FilePath] -> [FilePath] -> IO (Maybe FilePath) +doesFileExistOnPath filenames paths = go fullFilenames + where fullFilenames = [ (path, path filename) + | filename <- filenames + , path <- paths ] + go [] = return Nothing + go ((p, fp) : xs) = do b <- doesFileExist fp + if b then return (Just p) else go xs + +checkModules :: InstalledPackageInfo -> Validate () +checkModules pkg = do + mapM_ findModule (exposedModules pkg ++ hiddenModules pkg) + where + findModule modl = + -- there's no interface file for GHC.Prim + unless (modl == fromString "GHC.Prim") $ do + let files = [ toFilePath modl <.> extension + | extension <- ["hi", "p_hi", "dyn_hi" ] ] + m <- liftIO $ doesFileExistOnPath files (importDirs pkg) + when (isNothing m) $ + verror ForceFiles ("cannot find any of " ++ show files) + +checkGHCiLib :: Verbosity -> String -> String -> String -> Bool -> IO () +checkGHCiLib verbosity batch_lib_dir batch_lib_file lib auto_build + | auto_build = autoBuildGHCiLib verbosity batch_lib_dir batch_lib_file ghci_lib_file + | otherwise = return () + where + ghci_lib_file = lib <.> "o" + +-- automatically build the GHCi version of a batch lib, +-- using ld --whole-archive. + +autoBuildGHCiLib :: Verbosity -> String -> String -> String -> IO () +autoBuildGHCiLib verbosity dir batch_file ghci_file = do + let ghci_lib_file = dir ++ '/':ghci_file + batch_lib_file = dir ++ '/':batch_file + when (verbosity >= Normal) $ + info ("building GHCi library " ++ ghci_lib_file ++ "...") +#if defined(darwin_HOST_OS) + r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file] +#elif defined(mingw32_HOST_OS) + execDir <- getLibDir + r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file] +#else + r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file] +#endif + when (r /= ExitSuccess) $ exitWith r + when (verbosity >= Normal) $ + infoLn (" done.") + +-- ----------------------------------------------------------------------------- +-- Searching for modules + +#if not_yet + +findModules :: [FilePath] -> IO [String] +findModules paths = + mms <- mapM searchDir paths + return (concat mms) + +searchDir path prefix = do + fs <- getDirectoryEntries path `catchIO` \_ -> return [] + searchEntries path prefix fs + +searchEntries path prefix [] = return [] +searchEntries path prefix (f:fs) + | looks_like_a_module = do + ms <- searchEntries path prefix fs + return (prefix `joinModule` f : ms) + | looks_like_a_component = do + ms <- searchDir (path f) (prefix `joinModule` f) + ms' <- searchEntries path prefix fs + return (ms ++ ms') + | otherwise + searchEntries path prefix fs + + where + (base,suffix) = splitFileExt f + looks_like_a_module = + suffix `elem` haskell_suffixes && + all okInModuleName base + looks_like_a_component = + null suffix && all okInModuleName base + +okInModuleName c + +#endif + +-- --------------------------------------------------------------------------- +-- expanding environment variables in the package configuration + +expandEnvVars :: String -> Force -> IO String +expandEnvVars str0 force = go str0 "" + where + go "" acc = return $! reverse acc + go ('$':'{':str) acc | (var, '}':rest) <- break close str + = do value <- lookupEnvVar var + go rest (reverse value ++ acc) + where close c = c == '}' || c == '\n' -- don't span newlines + go (c:str) acc + = go str (c:acc) + + lookupEnvVar :: String -> IO String + lookupEnvVar "pkgroot" = return "${pkgroot}" -- these two are special, + lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them + lookupEnvVar nm = + catchIO (System.Environment.getEnv nm) + (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++ + show nm) + return "") + +----------------------------------------------------------------------------- + +getProgramName :: IO String +getProgramName = liftM (`withoutSuffix` ".bin") getProgName + where str `withoutSuffix` suff + | suff `isSuffixOf` str = take (length str - length suff) str + | otherwise = str + +bye :: String -> IO a +bye s = putStr s >> exitWith ExitSuccess + +die :: String -> IO a +die = dieWith 1 + +dieWith :: Int -> String -> IO a +dieWith ec s = do + prog <- getProgramName + reportError (prog ++ ": " ++ s) + exitWith (ExitFailure ec) + +dieOrForceAll :: Force -> String -> IO () +dieOrForceAll ForceAll s = ignoreError s +dieOrForceAll _other s = dieForcible s + +warn :: String -> IO () +warn = reportError + +-- send info messages to stdout +infoLn :: String -> IO () +infoLn = putStrLn + +info :: String -> IO () +info = putStr + +ignoreError :: String -> IO () +ignoreError s = reportError (s ++ " (ignoring)") + +reportError :: String -> IO () +reportError s = do hFlush stdout; hPutStrLn stderr s + +dieForcible :: String -> IO () +dieForcible s = die (s ++ " (use --force to override)") + +my_head :: String -> [a] -> a +my_head s [] = error s +my_head _ (x : _) = x + +getLibDir :: IO (Maybe String) +getLibDir = return $ Just hasteSysDir + +----------------------------------------- +-- Adapted from ghc/compiler/utils/Panic + +installSignalHandlers :: IO () +installSignalHandlers = do + threadid <- myThreadId + let + interrupt = Exception.throwTo threadid + (Exception.ErrorCall "interrupted") + -- +#if !defined(mingw32_HOST_OS) + _ <- installHandler sigQUIT (Catch interrupt) Nothing + _ <- installHandler sigINT (Catch interrupt) Nothing + return () +#else + -- GHC 6.3+ has support for console events on Windows + -- NOTE: running GHCi under a bash shell for some reason requires + -- you to press Ctrl-Break rather than Ctrl-C to provoke + -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know + -- why --SDM 17/12/2004 + let sig_handler ControlC = interrupt + sig_handler Break = interrupt + sig_handler _ = return () + + _ <- installHandler (Catch sig_handler) + return () +#endif + +#if mingw32_HOST_OS || mingw32_TARGET_OS +throwIOIO :: Exception.IOException -> IO a +throwIOIO = Exception.throwIO +#endif + +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +catchIO = Exception.catch + +catchError :: IO a -> (String -> IO a) -> IO a +catchError io handler = io `Exception.catch` handler' + where handler' (Exception.ErrorCall err) = handler err + +tryIO :: IO a -> IO (Either Exception.IOException a) +tryIO = Exception.try + +writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO () +writeBinaryFileAtomic targetFile obj = + withFileAtomic targetFile $ \h -> do + hSetBinaryMode h True + B.hPutStr h (Bin.encode obj) + +writeFileUtf8Atomic :: FilePath -> String -> IO () +writeFileUtf8Atomic targetFile content = + withFileAtomic targetFile $ \h -> do + hSetEncoding h utf8 + hPutStr h content + +-- copied from Cabal's Distribution.Simple.Utils, except that we want +-- to use text files here, rather than binary files. +withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO () +withFileAtomic targetFile write_content = do + (newFile, newHandle) <- openNewFile targetDir template + do write_content newHandle + hClose newHandle +#if mingw32_HOST_OS || mingw32_TARGET_OS + renameFile newFile targetFile + -- If the targetFile exists then renameFile will fail + `catchIO` \err -> do + exists <- doesFileExist targetFile + if exists + then do removeFileSafe targetFile + -- Big fat hairy race condition + renameFile newFile targetFile + -- If the removeFile succeeds and the renameFile fails + -- then we've lost the atomic property. + else throwIOIO err +#else + renameFile newFile targetFile +#endif + `Exception.onException` do hClose newHandle + removeFileSafe newFile + where + template = targetName <.> "tmp" + targetDir | null targetDir_ = "." + | otherwise = targetDir_ + --TODO: remove this when takeDirectory/splitFileName is fixed + -- to always return a valid dir + (targetDir_,targetName) = splitFileName targetFile + +openNewFile :: FilePath -> String -> IO (FilePath, Handle) +openNewFile dir template = do + -- this was added to System.IO in 6.12.1 + -- we must use this version because the version below opens the file + -- in binary mode. + openTempFileWithDefaultPermissions dir template + +-- | The function splits the given string to substrings +-- using 'isSearchPathSeparator'. +parseSearchPath :: String -> [FilePath] +parseSearchPath path = split path + where + split :: String -> [String] + split s = + case rest' of + [] -> [chunk] + _:rest -> chunk : split rest + where + chunk = + case chunk' of +#ifdef mingw32_HOST_OS + ('\"':xs@(_:_)) | last xs == '\"' -> init xs +#endif + _ -> chunk' + + (chunk', rest') = break isSearchPathSeparator s + +readUTF8File :: FilePath -> IO String +readUTF8File file = do + h <- openFile file ReadMode + -- fix the encoding to UTF-8 + hSetEncoding h utf8 + hGetContents h + +-- removeFileSave doesn't throw an exceptions, if the file is already deleted +removeFileSafe :: FilePath -> IO () +removeFileSafe fn = + removeFile fn `catchIO` \ e -> + when (not $ isDoesNotExistError e) $ ioError e + +absolutePath :: FilePath -> IO FilePath +absolutePath path = return . normalise . ( path) =<< getCurrentDirectory + +-- | Only global packages may be marked as relocatable! +-- May break horribly for general use, only reliable for Haste base packages. +relocate :: [String] -> String -> Sh.Shell () +relocate packages pkg = do + pi <- Sh.run hastePkgBinary (packages ++ ["describe", pkg]) "" + Sh.run_ hastePkgBinary (packages ++ ["update", "-", "--force", "--global"]) + (reloc pi) + where + reloc = unlines . map fixPath . lines + + fixPath s + | isKey "library-dirs: " s = prefix s "library-dirs" importDir + | isKey "import-dirs: " s = prefix s "import-dirs" importDir + | isKey "haddock-interfaces: " s = prefix s "haddock-interfaces" importDir + | isKey "haddock-html: " s = prefix s "haddock-html" importDir + | isKey "include-dirs: " s = "include-dirs: " ++ includeDir + | otherwise = s + + prefix s pfx path = pfx ++ ": " ++ path stripPrefix s + + stripPrefix = joinPath . dropWhile (not . isKey pkg) . splitPath + + isKey _ "" = + False + isKey key str = + and $ zipWith (==) key str + + importDir = "${pkgroot}" + includeDir = "${pkgroot}" "include" diff --git a/utils/haste-pkg/HastePkg710.hs b/utils/haste-pkg/HastePkg710.hs new file mode 100644 --- /dev/null +++ b/utils/haste-pkg/HastePkg710.hs @@ -0,0 +1,2095 @@ +{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, RecordWildCards, + GeneralizedNewtypeDeriving, StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2004-2009. +-- +-- Package management tool +-- +----------------------------------------------------------------------------- + +module HastePkg710 (main) where + +import qualified GHC.PackageDb as GhcPkg +import qualified Distribution.Simple.PackageIndex as PackageIndex +import qualified Data.Graph as Graph +import qualified Distribution.ModuleName as ModuleName +import Distribution.ModuleName (ModuleName) +import Distribution.InstalledPackageInfo as Cabal +import Distribution.Compat.ReadP hiding (get) +import Distribution.ParseUtils +import Distribution.Package hiding (depends, installedPackageId) +import Distribution.Text +import Distribution.Version +import Distribution.Simple.Utils (fromUTF8, toUTF8) +import System.FilePath as FilePath +import qualified System.FilePath.Posix as FilePath.Posix +import System.Process +import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing, + getModificationTime ) +import Text.Printf + +import Prelude + +import System.Console.GetOpt +import qualified Control.Exception as Exception +import Data.Maybe + +import Data.Char ( isSpace, toLower ) +import Data.Ord (comparing) +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative (Applicative(..)) +#endif +import Control.Monad +import System.Directory ( doesDirectoryExist, getDirectoryContents, + doesFileExist, renameFile, removeFile, + getCurrentDirectory ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.Environment ( getArgs, getProgName, getEnv ) +import System.IO +import System.IO.Error +import GHC.IO.Exception (IOErrorType(InappropriateType)) +import Data.List +import Control.Concurrent + +import qualified Data.ByteString.Char8 as BS + +-- Haste-specific +import Haste.Environment +import Haste.Version +import System.Info (os) +import qualified Control.Shell as Sh + +#if defined(mingw32_HOST_OS) +-- mingw32 needs these for getExecDir +import Foreign +import Foreign.C +#endif + +#ifdef mingw32_HOST_OS +import GHC.ConsoleHandler +#else +import System.Posix hiding (fdToHandle) +#endif + +#if defined(GLOB) +import qualified System.Info(os) +#endif + +#if !defined(mingw32_HOST_OS) && !defined(BOOTSTRAPPING) +import System.Console.Terminfo as Terminfo +#endif + +#ifdef mingw32_HOST_OS +# if defined(i386_HOST_ARCH) +# define WINDOWS_CCONV stdcall +# elif defined(x86_64_HOST_ARCH) +# define WINDOWS_CCONV ccall +# else +# error Unknown mingw32 arch +# endif +#endif + +-- ----------------------------------------------------------------------------- +-- Entry point + +main :: IO () +main = do + args <- getArgs + + case args of + ["relocate", pkg] -> do + Sh.shell (relocate packages pkg) >> exitWith ExitSuccess + _ -> + return () + + case getOpt Permute (flags ++ deprecFlags) args of + (cli,_,[]) | FlagHelp `elem` cli -> do + prog <- getProgramName + bye (usageInfo (usageHeader prog) flags) + (cli,_,[]) | FlagVersion `elem` cli -> + bye ourCopyright + (cli,_,[]) | FlagNumericVersion `elem` cli -> + bye $ showVersion hasteVersion ++ "\n" + (cli,_,[]) | FlagNumericGhcVersion `elem` cli -> + bye $ showVersion ghcVersion ++ "\n" + (cli,nonopts,[]) -> + case getVerbosity Normal cli of + Right v -> runit v cli nonopts + Left err -> die err + (_,_,errors) -> do + prog <- getProgramName + die (concat errors ++ shortUsage prog) + where + -- for relocate + packages = ["--global-package-db=" ++ pkgSysDir, + "--package-db=" ++ pkgSysDir, + "--package-db=" ++ pkgUserDir] + +-- ----------------------------------------------------------------------------- +-- Command-line syntax + +data Flag + = FlagUser + | FlagGlobal + | FlagHelp + | FlagVersion + | FlagNumericVersion + | FlagNumericGhcVersion + | FlagConfig FilePath + | FlagGlobalConfig FilePath + | FlagUserConfig FilePath + | FlagForce + | FlagForceFiles + | FlagAutoGHCiLibs + | FlagMultiInstance + | FlagExpandEnvVars + | FlagExpandPkgroot + | FlagNoExpandPkgroot + | FlagSimpleOutput + | FlagNamesOnly + | FlagIgnoreCase + | FlagNoUserDb + | FlagVerbosity (Maybe String) + | FlagIPId + | FlagPackageKey + deriving Eq + +flags :: [OptDescr Flag] +flags = [ + Option [] ["user"] (NoArg FlagUser) + "use the current user's package database", + Option [] ["global"] (NoArg FlagGlobal) + "use the global package database", + Option ['f'] ["package-db"] (ReqArg FlagConfig "FILE/DIR") + "use the specified package database", + Option [] ["package-conf"] (ReqArg FlagConfig "FILE/DIR") + "use the specified package database (DEPRECATED)", + Option [] ["global-package-db"] (ReqArg FlagGlobalConfig "DIR") + "location of the global package database", + Option [] ["no-user-package-db"] (NoArg FlagNoUserDb) + "never read the user package database", + Option [] ["user-package-db"] (ReqArg FlagUserConfig "DIR") + "location of the user package database (use instead of default)", + Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb) + "never read the user package database (DEPRECATED)", + Option [] ["force"] (NoArg FlagForce) + "ignore missing dependencies, directories, and libraries", + Option [] ["force-files"] (NoArg FlagForceFiles) + "ignore missing directories and libraries only", + Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs) + "automatically build libs for GHCi (with register)", + Option [] ["enable-multi-instance"] (NoArg FlagMultiInstance) + "allow registering multiple instances of the same package version", + Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars) + "expand environment variables (${name}-style) in input package descriptions", + Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot) + "expand ${pkgroot}-relative paths to absolute in output package descriptions", + Option [] ["no-expand-pkgroot"] (NoArg FlagNoExpandPkgroot) + "preserve ${pkgroot}-relative paths in output package descriptions", + Option ['?'] ["help"] (NoArg FlagHelp) + "display this help and exit", + Option ['V'] ["version"] (NoArg FlagVersion) + "output version information and exit", + Option [] ["numeric-version"] (NoArg FlagNumericVersion) + "output version number and exit", + Option [] ["numeric-ghc-version"] (NoArg FlagNumericGhcVersion) + "output GHC version number and exit", + Option [] ["simple-output"] (NoArg FlagSimpleOutput) + "print output in easy-to-parse format for some commands", + Option [] ["names-only"] (NoArg FlagNamesOnly) + "only print package names, not versions; can only be used with list --simple-output", + Option [] ["ignore-case"] (NoArg FlagIgnoreCase) + "ignore case for substring matching", + Option [] ["ipid"] (NoArg FlagIPId) + "interpret package arguments as installed package IDs", + Option [] ["package-key"] (NoArg FlagPackageKey) + "interpret package arguments as installed package keys", + Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity") + "verbosity level (0-2, default 1)" + ] + +data Verbosity = Silent | Normal | Verbose + deriving (Show, Eq, Ord) + +getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity +getVerbosity v [] = Right v +getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs +getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs +getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs +getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs +getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v) +getVerbosity v (_ : fs) = getVerbosity v fs + +deprecFlags :: [OptDescr Flag] +deprecFlags = [ + -- put deprecated flags here + ] + +ourCopyright :: String +ourCopyright = "Haste package manager version " ++ showVersion hasteVersion ++ "\n" + +shortUsage :: String -> String +shortUsage prog = "For usage information see '" ++ prog ++ " --help'." + +usageHeader :: String -> String +usageHeader prog = substProg prog $ + "Usage:\n" ++ + " $p init {path}\n" ++ + " Create and initialise a package database at the location {path}.\n" ++ + " Packages can be registered in the new database using the register\n" ++ + " command with --package-db={path}. To use the new database with GHC,\n" ++ + " use GHC's -package-db flag.\n" ++ + "\n" ++ + " $p register {filename | -}\n" ++ + " Register the package using the specified installed package\n" ++ + " description. The syntax for the latter is given in the $p\n" ++ + " documentation. The input file should be encoded in UTF-8.\n" ++ + "\n" ++ + " $p update {filename | -}\n" ++ + " Register the package, overwriting any other package with the\n" ++ + " same name. The input file should be encoded in UTF-8.\n" ++ + "\n" ++ + " $p unregister {pkg-id}\n" ++ + " Unregister the specified package.\n" ++ + "\n" ++ + " $p expose {pkg-id}\n" ++ + " Expose the specified package.\n" ++ + "\n" ++ + " $p hide {pkg-id}\n" ++ + " Hide the specified package.\n" ++ + "\n" ++ + " $p trust {pkg-id}\n" ++ + " Trust the specified package.\n" ++ + "\n" ++ + " $p distrust {pkg-id}\n" ++ + " Distrust the specified package.\n" ++ + "\n" ++ + " $p list [pkg]\n" ++ + " List registered packages in the global database, and also the\n" ++ + " user database if --user is given. If a package name is given\n" ++ + " all the registered versions will be listed in ascending order.\n" ++ + " Accepts the --simple-output flag.\n" ++ + "\n" ++ + " $p dot\n" ++ + " Generate a graph of the package dependencies in a form suitable\n" ++ + " for input for the graphviz tools. For example, to generate a PDF" ++ + " of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++ + "\n" ++ + " $p find-module {module}\n" ++ + " List registered packages exposing module {module} in the global\n" ++ + " database, and also the user database if --user is given.\n" ++ + " All the registered versions will be listed in ascending order.\n" ++ + " Accepts the --simple-output flag.\n" ++ + "\n" ++ + " $p latest {pkg-id}\n" ++ + " Prints the highest registered version of a package.\n" ++ + "\n" ++ + " $p check\n" ++ + " Check the consistency of package dependencies and list broken packages.\n" ++ + " Accepts the --simple-output flag.\n" ++ + "\n" ++ + " $p describe {pkg}\n" ++ + " Give the registered description for the specified package. The\n" ++ + " description is returned in precisely the syntax required by $p\n" ++ + " register.\n" ++ + "\n" ++ + " $p field {pkg} {field}\n" ++ + " Extract the specified field of the package description for the\n" ++ + " specified package. Accepts comma-separated multiple fields.\n" ++ + "\n" ++ + " $p dump\n" ++ + " Dump the registered description for every package. This is like\n" ++ + " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++ + " by tools that parse the results, rather than humans. The output is\n" ++ + " always encoded in UTF-8, regardless of the current locale.\n" ++ + "\n" ++ + " $p recache\n" ++ + " Regenerate the package database cache. This command should only be\n" ++ + " necessary if you added a package to the database by dropping a file\n" ++ + " into the database directory manually. By default, the global DB\n" ++ + " is recached; to recache a different DB use --user or --package-db\n" ++ + " as appropriate.\n" ++ + "\n" ++ + " Substring matching is supported for {module} in find-module and\n" ++ + " for {pkg} in list, describe, and field, where a '*' indicates\n" ++ + " open substring ends (prefix*, *suffix, *infix*). Use --ipid to\n" ++ + " match against the installed package ID instead.\n" ++ + "\n" ++ + " When asked to modify a database (register, unregister, update,\n"++ + " hide, expose, and also check), ghc-pkg modifies the global database by\n"++ + " default. Specifying --user causes it to act on the user database,\n"++ + " or --package-db can be used to act on another database\n"++ + " entirely. When multiple of these options are given, the rightmost\n"++ + " one is used as the database to act upon.\n"++ + "\n"++ + " Commands that query the package database (list, tree, latest, describe,\n"++ + " field) operate on the list of databases specified by the flags\n"++ + " --user, --global, and --package-db. If none of these flags are\n"++ + " given, the default is --global --user.\n"++ + "\n" ++ + " The following optional flags are also accepted:\n" + +substProg :: String -> String -> String +substProg _ [] = [] +substProg prog ('$':'p':xs) = prog ++ substProg prog xs +substProg prog (c:xs) = c : substProg prog xs + +-- ----------------------------------------------------------------------------- +-- Do the business + +data Force = NoForce | ForceFiles | ForceAll | CannotForce + deriving (Eq,Ord) + +-- | Enum flag representing argument type +data AsPackageArg + = AsIpid + | AsPackageKey + | AsDefault + +-- | Represents how a package may be specified by a user on the command line. +data PackageArg + -- | A package identifier foo-0.1; the version might be a glob. + = Id PackageIdentifier + -- | An installed package ID foo-0.1-HASH. This is guaranteed to uniquely + -- match a single entry in the package database. + | IPId InstalledPackageId + -- | A package key foo_HASH. This is also guaranteed to uniquely match + -- a single entry in the package database + | PkgKey PackageKey + -- | A glob against the package name. The first string is the literal + -- glob, the second is a function which returns @True@ if the the argument + -- matches. + | Substring String (String->Bool) + +runit :: Verbosity -> [Flag] -> [String] -> IO () +runit verbosity cli nonopts = do + installSignalHandlers -- catch ^C and clean up + prog <- getProgramName + let + force + | FlagForce `elem` cli = ForceAll + | FlagForceFiles `elem` cli = ForceFiles + | otherwise = NoForce + as_arg | FlagIPId `elem` cli = AsIpid + | FlagPackageKey `elem` cli = AsPackageKey + | otherwise = AsDefault + auto_ghci_libs = FlagAutoGHCiLibs `elem` cli + multi_instance = FlagMultiInstance `elem` cli + expand_env_vars= FlagExpandEnvVars `elem` cli + mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli + where accumExpandPkgroot _ FlagExpandPkgroot = Just True + accumExpandPkgroot _ FlagNoExpandPkgroot = Just False + accumExpandPkgroot x _ = x + + splitFields fields = unfoldr splitComma (',':fields) + where splitComma "" = Nothing + splitComma fs = Just $ break (==',') (tail fs) + + -- | Parses a glob into a predicate which tests if a string matches + -- the glob. Returns Nothing if the string in question is not a glob. + -- At the moment, we only support globs at the beginning and/or end of + -- strings. This function respects case sensitivity. + -- + -- >>> fromJust (substringCheck "*") "anything" + -- True + -- + -- >>> fromJust (substringCheck "string") "string" + -- True + -- + -- >>> fromJust (substringCheck "*bar") "foobar" + -- True + -- + -- >>> fromJust (substringCheck "foo*") "foobar" + -- True + -- + -- >>> fromJust (substringCheck "*ooba*") "foobar" + -- True + -- + -- >>> fromJust (substringCheck "f*bar") "foobar" + -- False + substringCheck :: String -> Maybe (String -> Bool) + substringCheck "" = Nothing + substringCheck "*" = Just (const True) + substringCheck [_] = Nothing + substringCheck (h:t) = + case (h, init t, last t) of + ('*',s,'*') -> Just (isInfixOf (f s) . f) + ('*',_, _ ) -> Just (isSuffixOf (f t) . f) + ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f) + _ -> Nothing + where f | FlagIgnoreCase `elem` cli = map toLower + | otherwise = id +#if defined(GLOB) + glob x | System.Info.os=="mingw32" = do + -- glob echoes its argument, after win32 filename globbing + (_,o,_,_) <- runInteractiveCommand ("glob "++x) + txt <- hGetContents o + return (read txt) + glob x | otherwise = return [x] +#endif + -- + -- first, parse the command + case nonopts of +#if defined(GLOB) + -- dummy command to demonstrate usage and permit testing + -- without messing things up; use glob to selectively enable + -- windows filename globbing for file parameters + -- register, update, FlagGlobalConfig, FlagConfig; others? + ["glob", filename] -> do + print filename + glob filename >>= print +#endif + ["init", filename] -> + initPackageDB filename verbosity cli + ["register", filename] -> + registerPackage filename verbosity cli + auto_ghci_libs multi_instance + expand_env_vars False force + ["update", filename] -> + registerPackage filename verbosity cli + auto_ghci_libs multi_instance + expand_env_vars True force + ["unregister", pkgarg_str] -> do + pkgarg <- readPackageArg as_arg pkgarg_str + unregisterPackage pkgarg verbosity cli force + ["expose", pkgarg_str] -> do + pkgarg <- readPackageArg as_arg pkgarg_str + exposePackage pkgarg verbosity cli force + ["hide", pkgarg_str] -> do + pkgarg <- readPackageArg as_arg pkgarg_str + hidePackage pkgarg verbosity cli force + ["trust", pkgarg_str] -> do + pkgarg <- readPackageArg as_arg pkgarg_str + trustPackage pkgarg verbosity cli force + ["distrust", pkgarg_str] -> do + pkgarg <- readPackageArg as_arg pkgarg_str + distrustPackage pkgarg verbosity cli force + ["list"] -> do + listPackages verbosity cli Nothing Nothing + ["list", pkgarg_str] -> + case substringCheck pkgarg_str of + Nothing -> do pkgarg <- readPackageArg as_arg pkgarg_str + listPackages verbosity cli (Just pkgarg) Nothing + Just m -> listPackages verbosity cli + (Just (Substring pkgarg_str m)) Nothing + ["dot"] -> do + showPackageDot verbosity cli + ["find-module", moduleName] -> do + let match = maybe (==moduleName) id (substringCheck moduleName) + listPackages verbosity cli Nothing (Just match) + ["latest", pkgid_str] -> do + pkgid <- readGlobPkgId pkgid_str + latestPackage verbosity cli pkgid + ["describe", pkgid_str] -> do + pkgarg <- case substringCheck pkgid_str of + Nothing -> readPackageArg as_arg pkgid_str + Just m -> return (Substring pkgid_str m) + describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot) + + ["field", pkgid_str, fields] -> do + pkgarg <- case substringCheck pkgid_str of + Nothing -> readPackageArg as_arg pkgid_str + Just m -> return (Substring pkgid_str m) + describeField verbosity cli pkgarg + (splitFields fields) (fromMaybe True mexpand_pkgroot) + + ["check"] -> do + checkConsistency verbosity cli + + ["dump"] -> do + dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot) + + ["recache"] -> do + recache verbosity cli + + [] -> do + die ("missing command\n" ++ shortUsage prog) + (_cmd:_) -> do + die ("command-line syntax error\n" ++ shortUsage prog) + +parseCheck :: ReadP a a -> String -> String -> IO a +parseCheck parser str what = + case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of + [x] -> return x + _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what) + +readGlobPkgId :: String -> IO PackageIdentifier +readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier" + +parseGlobPackageId :: ReadP r PackageIdentifier +parseGlobPackageId = + parse + +++ + (do n <- parse + _ <- string "-*" + return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion })) + +readPackageArg :: AsPackageArg -> String -> IO PackageArg +readPackageArg AsIpid str = + parseCheck (IPId `fmap` parse) str "installed package id" +readPackageArg AsPackageKey str = + parseCheck (PkgKey `fmap` parse) str "package key" +readPackageArg AsDefault str = Id `fmap` readGlobPkgId str + +-- globVersion means "all versions" +globVersion :: Version +globVersion = Version [] ["*"] + +-- ----------------------------------------------------------------------------- +-- Package databases + +-- Some commands operate on a single database: +-- register, unregister, expose, hide, trust, distrust +-- however these commands also check the union of the available databases +-- in order to check consistency. For example, register will check that +-- dependencies exist before registering a package. +-- +-- Some commands operate on multiple databases, with overlapping semantics: +-- list, describe, field + +data PackageDB + = PackageDB { + location, locationAbsolute :: !FilePath, + -- We need both possibly-relative and definately-absolute package + -- db locations. This is because the relative location is used as + -- an identifier for the db, so it is important we do not modify it. + -- On the other hand we need the absolute path in a few places + -- particularly in relation to the ${pkgroot} stuff. + + packages :: [InstalledPackageInfo] + } + +type PackageDBStack = [PackageDB] + -- A stack of package databases. Convention: head is the topmost + -- in the stack. + +allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo] +allPackagesInStack = concatMap packages + +getPkgDatabases :: Verbosity + -> Bool -- we are modifying, not reading + -> Bool -- use the user db + -> Bool -- read caches, if available + -> Bool -- expand vars, like ${pkgroot} and $topdir + -> [Flag] + -> IO (PackageDBStack, + -- the real package DB stack: [global,user] ++ + -- DBs specified on the command line with -f. + Maybe FilePath, + -- which one to modify, if any + PackageDBStack) + -- the package DBs specified on the command + -- line, or [global,user] otherwise. This + -- is used as the list of package DBs for + -- commands that just read the DB, such as 'list'. + +getPkgDatabases verbosity modify use_user use_cache expand_vars my_flags = do + -- first we determine the location of the global package config. On Windows, + -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the + -- location is passed to the binary using the --global-package-db flag by the + -- wrapper script. + let err_msg = "missing --global-package-db option, location of global package database unknown\n" + global_conf <- + case [ f | FlagGlobalConfig f <- my_flags ] of + [] -> do mb_dir <- getLibDir + case mb_dir of + Nothing -> die err_msg + Just dir -> do + r <- lookForPackageDBIn dir + case r of + Nothing -> die ("Can't find package database in " ++ dir) + Just path -> return path + fs -> return (last fs) + + -- The value of the $topdir variable used in some package descriptions + -- Note that the way we calculate this is slightly different to how it + -- is done in ghc itself. We rely on the convention that the global + -- package db lives in ghc's libdir. + top_dir <- absolutePath (takeDirectory global_conf) + + let no_user_db = FlagNoUserDb `elem` my_flags + + mb_user_conf <- + case [ f | FlagUserConfig f <- my_flags ] of + _ | no_user_db -> return Nothing + [] -> do + r <- lookForPackageDBIn hasteUserDir + case r of + Nothing -> return (Just (pkgUserDir, False)) + Just f -> return (Just (f, True)) + fs -> return (Just (last fs, True)) + + -- If the user database exists, and for "use_user" commands (which includes + -- "ghc-pkg check" and all commands that modify the db) we will attempt to + -- use the user db. + let sys_databases + | Just (user_conf,user_exists) <- mb_user_conf, + use_user || user_exists = [user_conf, global_conf] + | otherwise = [global_conf] + + e_pkg_path <- tryIO (System.Environment.getEnv "HASTE_PACKAGE_PATH") + let env_stack = + nub $ case e_pkg_path of + Left _ -> sys_databases + Right path + | not (null path) && isSearchPathSeparator (last path) + -> splitSearchPath (init path) ++ sys_databases + | otherwise + -> splitSearchPath path + + -- The "global" database is always the one at the bottom of the stack. + -- This is the database we modify by default. + virt_global_conf = last env_stack + + let db_flags = [ f | Just f <- map is_db_flag my_flags ] + where is_db_flag FlagUser + | Just (user_conf, _user_exists) <- mb_user_conf + = Just user_conf + is_db_flag FlagGlobal = Just virt_global_conf + is_db_flag (FlagConfig f) = Just f + is_db_flag _ = Nothing + + let flag_db_names | null db_flags = env_stack + | otherwise = reverse (nub db_flags) + + -- For a "modify" command, treat all the databases as + -- a stack, where we are modifying the top one, but it + -- can refer to packages in databases further down the + -- stack. + + -- -f flags on the command line add to the database + -- stack, unless any of them are present in the stack + -- already. + let final_stack = filter (`notElem` env_stack) + [ f | FlagConfig f <- reverse my_flags ] + ++ env_stack + + -- the database we actually modify is the one mentioned + -- rightmost on the command-line. + let to_modify + | not modify = Nothing + | null db_flags = Just virt_global_conf + | otherwise = Just (last db_flags) + + db_stack <- sequence + [ do db <- readParseDatabase verbosity mb_user_conf modify use_cache db_path + if expand_vars then return (mungePackageDBPaths top_dir db) + else return db + | db_path <- final_stack ] + + let flag_db_stack = [ db | db_name <- flag_db_names, + db <- db_stack, location db == db_name ] + + when (verbosity > Normal) $ do + infoLn ("db stack: " ++ show (map location db_stack)) + infoLn ("modifying: " ++ show to_modify) + infoLn ("flag db stack: " ++ show (map location flag_db_stack)) + + return (db_stack, to_modify, flag_db_stack) + + +lookForPackageDBIn :: FilePath -> IO (Maybe FilePath) +lookForPackageDBIn dir = do + let path_dir = dir "package.conf.d" + exists_dir <- doesDirectoryExist path_dir + if exists_dir then return (Just path_dir) else do + let path_file = dir "package.conf" + exists_file <- doesFileExist path_file + if exists_file then return (Just path_file) else return Nothing + +readParseDatabase :: Verbosity + -> Maybe (FilePath,Bool) + -> Bool -- we will be modifying, not just reading + -> Bool -- use cache + -> FilePath + -> IO PackageDB + +readParseDatabase verbosity mb_user_conf modify use_cache path + -- the user database (only) is allowed to be non-existent + | Just (user_conf,False) <- mb_user_conf, path == user_conf + = mkPackageDB [] + | otherwise + = do e <- tryIO $ getDirectoryContents path + case e of + Left err + | ioeGetErrorType err == InappropriateType -> + die ("ghc no longer supports single-file style package databases " + ++ "(" ++ path ++ ") use 'ghc-pkg init' to create the database " + ++ "with the correct format.") + | otherwise -> ioError err + Right fs + | not use_cache -> ignore_cache (const $ return ()) + | otherwise -> do + let cache = path cachefilename + tdir <- getModificationTime path + e_tcache <- tryIO $ getModificationTime cache + case e_tcache of + Left ex -> do + whenReportCacheErrors $ + if isDoesNotExistError ex + then do + warn ("WARNING: cache does not exist: " ++ cache) + warn ("ghc will fail to read this package db. " ++ + "Use 'ghc-pkg recache' to fix.") + else do + warn ("WARNING: cache cannot be read: " ++ show ex) + warn "ghc will fail to read this package db." + ignore_cache (const $ return ()) + Right tcache -> do + let compareTimestampToCache file = + when (verbosity >= Verbose) $ do + tFile <- getModificationTime file + compareTimestampToCache' file tFile + compareTimestampToCache' file tFile = do + let rel = case tcache `compare` tFile of + LT -> " (NEWER than cache)" + GT -> " (older than cache)" + EQ -> " (same as cache)" + warn ("Timestamp " ++ show tFile + ++ " for " ++ file ++ rel) + when (verbosity >= Verbose) $ do + warn ("Timestamp " ++ show tcache ++ " for " ++ cache) + compareTimestampToCache' path tdir + if tcache >= tdir + then do + when (verbosity > Normal) $ + infoLn ("using cache: " ++ cache) + pkgs <- GhcPkg.readPackageDbForGhcPkg cache + mkPackageDB pkgs + else do + whenReportCacheErrors $ do + warn ("WARNING: cache is out of date: " ++ cache) + warn ("ghc will see an old view of this " ++ + "package db. Use 'ghc-pkg recache' to fix.") + ignore_cache compareTimestampToCache + where + ignore_cache :: (FilePath -> IO ()) -> IO PackageDB + ignore_cache checkTime = do + let confs = filter (".conf" `isSuffixOf`) fs + doFile f = do checkTime f + parseSingletonPackageConf verbosity f + pkgs <- mapM doFile $ map (path ) confs + mkPackageDB pkgs + + -- We normally report cache errors for read-only commands, + -- since modify commands because will usually fix the cache. + whenReportCacheErrors = + when ( verbosity > Normal + || verbosity >= Normal && not modify) + where + mkPackageDB pkgs = do + path_abs <- absolutePath path + return PackageDB { + location = path, + locationAbsolute = path_abs, + packages = pkgs + } + +parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo +parseSingletonPackageConf verbosity file = do + when (verbosity > Normal) $ infoLn ("reading package config: " ++ file) + readUTF8File file >>= fmap fst . parsePackageInfo + +cachefilename :: FilePath +cachefilename = "package.cache" + +mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB +mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } = + db { packages = map (mungePackagePaths top_dir pkgroot) pkgs } + where + pkgroot = takeDirectory (locationAbsolute db) + -- It so happens that for both styles of package db ("package.conf" + -- files and "package.conf.d" dirs) the pkgroot is the parent directory + -- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/ + +-- TODO: This code is duplicated in compiler/main/Packages.lhs +mungePackagePaths :: FilePath -> FilePath + -> InstalledPackageInfo -> InstalledPackageInfo +-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec +-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) +-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. +-- The "pkgroot" is the directory containing the package database. +-- +-- Also perform a similar substitution for the older GHC-specific +-- "$topdir" variable. The "topdir" is the location of the ghc +-- installation (obtained from the -B option). +mungePackagePaths top_dir pkgroot pkg = + pkg { + importDirs = munge_paths (importDirs pkg), + includeDirs = munge_paths (includeDirs pkg), + libraryDirs = munge_paths (libraryDirs pkg), + frameworkDirs = munge_paths (frameworkDirs pkg), + haddockInterfaces = munge_paths (haddockInterfaces pkg), + -- haddock-html is allowed to be either a URL or a file + haddockHTMLs = munge_paths (munge_urls (haddockHTMLs pkg)) + } + where + munge_paths = map munge_path + munge_urls = map munge_url + + munge_path p + | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p' + | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p' + | otherwise = p + + munge_url p + | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p' + | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p' + | otherwise = p + + toUrlPath r p = "file:///" + -- URLs always use posix style '/' separators: + ++ FilePath.Posix.joinPath + (r : -- We need to drop a leading "/" or "\\" + -- if there is one: + dropWhile (all isPathSeparator) + (FilePath.splitDirectories p)) + + -- We could drop the separator here, and then use above. However, + -- by leaving it in and using ++ we keep the same path separator + -- rather than letting FilePath change it to use \ as the separator + stripVarPrefix var path = case stripPrefix var path of + Just [] -> Just [] + Just cs@(c : _) | isPathSeparator c -> Just cs + _ -> Nothing + + +-- ----------------------------------------------------------------------------- +-- Creating a new package DB + +initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO () +initPackageDB filename verbosity _flags = do + let eexist = die ("cannot create: " ++ filename ++ " already exists") + b1 <- doesFileExist filename + when b1 eexist + b2 <- doesDirectoryExist filename + when b2 eexist + filename_abs <- absolutePath filename + changeDB verbosity [] PackageDB { + location = filename, locationAbsolute = filename_abs, + packages = [] + } + +-- ----------------------------------------------------------------------------- +-- Registering + +registerPackage :: FilePath + -> Verbosity + -> [Flag] + -> Bool -- auto_ghci_libs + -> Bool -- multi_instance + -> Bool -- expand_env_vars + -> Bool -- update + -> Force + -> IO () +registerPackage input verbosity my_flags auto_ghci_libs multi_instance + expand_env_vars update force = do + (db_stack, Just to_modify, _flag_dbs) <- + getPkgDatabases verbosity True{-modify-} True{-use user-} + True{-use cache-} False{-expand vars-} my_flags + + let + db_to_operate_on = my_head "register" $ + filter ((== to_modify).location) db_stack + -- + when (auto_ghci_libs && verbosity >= Silent) $ + warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4" + -- + s <- + case input of + "-" -> do + when (verbosity >= Normal) $ + info "Reading package info from stdin ... " + -- fix the encoding to UTF-8, since this is an interchange format + hSetEncoding stdin utf8 + getContents + f -> do + when (verbosity >= Normal) $ + info ("Reading package info from " ++ show f ++ " ... ") + readUTF8File f + + expanded <- if expand_env_vars then expandEnvVars s force + else return s + + (pkg, ws) <- parsePackageInfo expanded + when (verbosity >= Normal) $ + infoLn "done." + + -- report any warnings from the parse phase + _ <- reportValidateErrors [] ws + (display (sourcePackageId pkg) ++ ": Warning: ") Nothing + + -- validate the expanded pkg, but register the unexpanded + pkgroot <- absolutePath (takeDirectory to_modify) + let top_dir = takeDirectory (location (last db_stack)) + pkg_expanded = mungePackagePaths top_dir pkgroot pkg + + let truncated_stack = dropWhile ((/= to_modify).location) db_stack + -- truncate the stack for validation, because we don't allow + -- packages lower in the stack to refer to those higher up. + validatePackageConfig pkg_expanded verbosity truncated_stack + auto_ghci_libs multi_instance update force + + let + -- In the normal mode, we only allow one version of each package, so we + -- remove all instances with the same source package id as the one we're + -- adding. In the multi instance mode we don't do that, thus allowing + -- multiple instances with the same source package id. + removes = [ RemovePackage p + | not multi_instance, + p <- packages db_to_operate_on, + sourcePackageId p == sourcePackageId pkg ] + -- + changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on + +parsePackageInfo + :: String + -> IO (InstalledPackageInfo, [ValidateWarning]) +parsePackageInfo str = + case parseInstalledPackageInfo str of + ParseOk warnings ok -> return (mungePackageInfo ok, ws) + where + ws = [ msg | PWarning msg <- warnings + , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ] + ParseFailed err -> case locatedErrorMsg err of + (Nothing, s) -> die s + (Just l, s) -> die (show l ++ ": " ++ s) + +mungePackageInfo :: InstalledPackageInfo -> InstalledPackageInfo +mungePackageInfo ipi = ipi { packageKey = packageKey' } + where + packageKey' + | OldPackageKey (PackageIdentifier (PackageName "") _) <- packageKey ipi + = OldPackageKey (sourcePackageId ipi) + | otherwise = packageKey ipi + +-- ----------------------------------------------------------------------------- +-- Making changes to a package database + +data DBOp = RemovePackage InstalledPackageInfo + | AddPackage InstalledPackageInfo + | ModifyPackage InstalledPackageInfo + +changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO () +changeDB verbosity cmds db = do + let db' = updateInternalDB db cmds + createDirectoryIfMissing True (location db) + changeDBDir verbosity cmds db' + +updateInternalDB :: PackageDB -> [DBOp] -> PackageDB +updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds } + where + do_cmd pkgs (RemovePackage p) = + filter ((/= installedPackageId p) . installedPackageId) pkgs + do_cmd pkgs (AddPackage p) = p : pkgs + do_cmd pkgs (ModifyPackage p) = + do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p) + + +changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO () +changeDBDir verbosity cmds db = do + mapM_ do_cmd cmds + updateDBCache verbosity db + where + do_cmd (RemovePackage p) = do + let file = location db display (installedPackageId p) <.> "conf" + when (verbosity > Normal) $ infoLn ("removing " ++ file) + removeFileSafe file + do_cmd (AddPackage p) = do + let file = location db display (installedPackageId p) <.> "conf" + when (verbosity > Normal) $ infoLn ("writing " ++ file) + writeFileUtf8Atomic file (showInstalledPackageInfo p) + do_cmd (ModifyPackage p) = + do_cmd (AddPackage p) + +updateDBCache :: Verbosity -> PackageDB -> IO () +updateDBCache verbosity db = do + let filename = location db cachefilename + + pkgsCabalFormat :: [InstalledPackageInfo] + pkgsCabalFormat = packages db + + pkgsGhcCacheFormat :: [PackageCacheFormat] + pkgsGhcCacheFormat = map convertPackageInfoToCacheFormat pkgsCabalFormat + + when (verbosity > Normal) $ + infoLn ("writing cache " ++ filename) + GhcPkg.writePackageDb filename pkgsGhcCacheFormat pkgsCabalFormat + `catchIO` \e -> + if isPermissionError e + then die (filename ++ ": you don't have permission to modify this file") + else ioError e + -- See Note [writeAtomic leaky abstraction] + -- Cross-platform "touch". This only works if filename is not empty, and not + -- open for writing already. + -- TODO. When the Win32 or directory packages have either a touchFile or a + -- setModificationTime function, use one of those. + withBinaryFile filename ReadWriteMode $ \handle -> do + c <- hGetChar handle + hSeek handle AbsoluteSeek 0 + hPutChar handle c + +type PackageCacheFormat = GhcPkg.InstalledPackageInfo + String -- installed package id + String -- src package id + String -- package name + String -- package key + ModuleName -- module name + +convertPackageInfoToCacheFormat :: InstalledPackageInfo -> PackageCacheFormat +convertPackageInfoToCacheFormat pkg = + GhcPkg.InstalledPackageInfo { + GhcPkg.installedPackageId = display (installedPackageId pkg), + GhcPkg.sourcePackageId = display (sourcePackageId pkg), + GhcPkg.packageName = display (packageName pkg), + GhcPkg.packageVersion = packageVersion pkg, + GhcPkg.packageKey = display (packageKey pkg), + GhcPkg.depends = map display (depends pkg), + GhcPkg.importDirs = importDirs pkg, + GhcPkg.hsLibraries = hsLibraries pkg, + GhcPkg.extraLibraries = extraLibraries pkg, + GhcPkg.extraGHCiLibraries = extraGHCiLibraries pkg, + GhcPkg.libraryDirs = libraryDirs pkg, + GhcPkg.frameworks = frameworks pkg, + GhcPkg.frameworkDirs = frameworkDirs pkg, + GhcPkg.ldOptions = ldOptions pkg, + GhcPkg.ccOptions = ccOptions pkg, + GhcPkg.includes = includes pkg, + GhcPkg.includeDirs = includeDirs pkg, + GhcPkg.haddockInterfaces = haddockInterfaces pkg, + GhcPkg.haddockHTMLs = haddockHTMLs pkg, + GhcPkg.exposedModules = map convertExposed (exposedModules pkg), + GhcPkg.hiddenModules = hiddenModules pkg, + GhcPkg.instantiatedWith = map convertInst (instantiatedWith pkg), + GhcPkg.exposed = exposed pkg, + GhcPkg.trusted = trusted pkg + } + where convertExposed (ExposedModule n reexport sig) = + GhcPkg.ExposedModule n (fmap convertOriginal reexport) + (fmap convertOriginal sig) + convertOriginal (OriginalModule ipid m) = + GhcPkg.OriginalModule (display ipid) m + convertInst (m, o) = (m, convertOriginal o) + +instance GhcPkg.BinaryStringRep ModuleName where + fromStringRep = ModuleName.fromString . fromUTF8 . BS.unpack + toStringRep = BS.pack . toUTF8 . display + +instance GhcPkg.BinaryStringRep String where + fromStringRep = fromUTF8 . BS.unpack + toStringRep = BS.pack . toUTF8 + + +-- ----------------------------------------------------------------------------- +-- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar + +exposePackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO () +exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True}) + +hidePackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO () +hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False}) + +trustPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO () +trustPackage = modifyPackage (\p -> ModifyPackage p{trusted=True}) + +distrustPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO () +distrustPackage = modifyPackage (\p -> ModifyPackage p{trusted=False}) + +unregisterPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO () +unregisterPackage = modifyPackage RemovePackage + +modifyPackage + :: (InstalledPackageInfo -> DBOp) + -> PackageArg + -> Verbosity + -> [Flag] + -> Force + -> IO () +modifyPackage fn pkgarg verbosity my_flags force = do + (db_stack, Just _to_modify, flag_dbs) <- + getPkgDatabases verbosity True{-modify-} True{-use user-} + True{-use cache-} False{-expand vars-} my_flags + + -- Do the search for the package respecting flags... + (db, ps) <- fmap head $ findPackagesByDB flag_dbs pkgarg + let + db_name = location db + pkgs = packages db + + pks = map packageKey ps + + cmds = [ fn pkg | pkg <- pkgs, packageKey pkg `elem` pks ] + new_db = updateInternalDB db cmds + + -- ...but do consistency checks with regards to the full stack + old_broken = brokenPackages (allPackagesInStack db_stack) + rest_of_stack = filter ((/= db_name) . location) db_stack + new_stack = new_db : rest_of_stack + new_broken = brokenPackages (allPackagesInStack new_stack) + newly_broken = filter ((`notElem` map packageKey old_broken) + . packageKey) new_broken + -- + let displayQualPkgId pkg + | [_] <- filter ((== pkgid) . sourcePackageId) + (allPackagesInStack db_stack) + = display pkgid + | otherwise = display pkgid ++ "@" ++ display (packageKey pkg) + where pkgid = sourcePackageId pkg + when (not (null newly_broken)) $ + dieOrForceAll force ("unregistering would break the following packages: " + ++ unwords (map displayQualPkgId newly_broken)) + + changeDB verbosity cmds db + +recache :: Verbosity -> [Flag] -> IO () +recache verbosity my_flags = do + (db_stack, Just to_modify, _flag_dbs) <- + getPkgDatabases verbosity True{-modify-} True{-use user-} False{-no cache-} + False{-expand vars-} my_flags + let + db_to_operate_on = my_head "recache" $ + filter ((== to_modify).location) db_stack + -- + changeDB verbosity [] db_to_operate_on + +-- ----------------------------------------------------------------------------- +-- Listing packages + +listPackages :: Verbosity -> [Flag] -> Maybe PackageArg + -> Maybe (String->Bool) + -> IO () +listPackages verbosity my_flags mPackageName mModuleName = do + let simple_output = FlagSimpleOutput `elem` my_flags + (db_stack, _, flag_db_stack) <- + getPkgDatabases verbosity False{-modify-} False{-use user-} + True{-use cache-} False{-expand vars-} my_flags + + let db_stack_filtered -- if a package is given, filter out all other packages + | Just this <- mPackageName = + [ db{ packages = filter (this `matchesPkg`) (packages db) } + | db <- flag_db_stack ] + | Just match <- mModuleName = -- packages which expose mModuleName + [ db{ packages = filter (match `exposedInPkg`) (packages db) } + | db <- flag_db_stack ] + | otherwise = flag_db_stack + + db_stack_sorted + = [ db{ packages = sort_pkgs (packages db) } + | db <- db_stack_filtered ] + where sort_pkgs = sortBy cmpPkgIds + cmpPkgIds pkg1 pkg2 = + case pkgName p1 `compare` pkgName p2 of + LT -> LT + GT -> GT + EQ -> case pkgVersion p1 `compare` pkgVersion p2 of + LT -> LT + GT -> GT + EQ -> packageKey pkg1 `compare` packageKey pkg2 + where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2) + + stack = reverse db_stack_sorted + + match `exposedInPkg` pkg = any match (map display $ exposedModules pkg) + + pkg_map = allPackagesInStack db_stack + broken = map packageKey (brokenPackages pkg_map) + + show_normal PackageDB{ location = db_name, packages = pkg_confs } = + do hPutStrLn stdout (db_name ++ ":") + if null pp_pkgs + then hPutStrLn stdout " (no packages)" + else hPutStrLn stdout $ unlines (map (" " ++) pp_pkgs) + where + -- Sort using instance Ord PackageId + pp_pkgs = map pp_pkg . sortBy (comparing installedPackageId) $ pkg_confs + pp_pkg p + | packageKey p `elem` broken = printf "{%s}" doc + | exposed p = doc + | otherwise = printf "(%s)" doc + where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid + | otherwise = pkg + where + InstalledPackageId ipid = installedPackageId p + pkg = display (sourcePackageId p) + + show_simple = simplePackageList my_flags . allPackagesInStack + + when (not (null broken) && not simple_output && verbosity /= Silent) $ do + prog <- getProgramName + warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.") + + if simple_output then show_simple stack else do + +#if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING) + mapM_ show_normal stack +#else + let + show_colour withF db = + mconcat $ map (<#> termText "\n") $ + (termText (location db) : + map (termText " " <#>) (map pp_pkg (packages db))) + where + pp_pkg p + | packageKey p `elem` broken = withF Red doc + | exposed p = doc + | otherwise = withF Blue doc + where doc | verbosity >= Verbose + = termText (printf "%s (%s)" pkg ipid) + | otherwise + = termText pkg + where + InstalledPackageId ipid = installedPackageId p + pkg = display (sourcePackageId p) + + is_tty <- hIsTerminalDevice stdout + if not is_tty + then mapM_ show_normal stack + else do tty <- Terminfo.setupTermFromEnv + case Terminfo.getCapability tty withForegroundColor of + Nothing -> mapM_ show_normal stack + Just w -> runTermOutput tty $ mconcat $ + map (show_colour w) stack +#endif + +simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO () +simplePackageList my_flags pkgs = do + let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName + else display + -- Sort using instance Ord PackageId + strs = map showPkg $ sort $ map sourcePackageId pkgs + when (not (null pkgs)) $ + hPutStrLn stdout $ concat $ intersperse " " strs + +showPackageDot :: Verbosity -> [Flag] -> IO () +showPackageDot verbosity myflags = do + (_, _, flag_db_stack) <- + getPkgDatabases verbosity False{-modify-} False{-use user-} + True{-use cache-} False{-expand vars-} myflags + + let all_pkgs = allPackagesInStack flag_db_stack + ipix = PackageIndex.fromList all_pkgs + + putStrLn "digraph {" + let quote s = '"':s ++ "\"" + mapM_ putStrLn [ quote from ++ " -> " ++ quote to + | p <- all_pkgs, + let from = display (sourcePackageId p), + depid <- depends p, + Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid], + let to = display (sourcePackageId dep) + ] + putStrLn "}" + +-- ----------------------------------------------------------------------------- +-- Prints the highest (hidden or exposed) version of a package + +-- ToDo: This is no longer well-defined with package keys, because the +-- dependencies may be varying versions +latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO () +latestPackage verbosity my_flags pkgid = do + (_, _, flag_db_stack) <- + getPkgDatabases verbosity False{-modify-} False{-use user-} + True{-use cache-} False{-expand vars-} my_flags + + ps <- findPackages flag_db_stack (Id pkgid) + case ps of + [] -> die "no matches" + _ -> show_pkg . maximum . map sourcePackageId $ ps + where + show_pkg pid = hPutStrLn stdout (display pid) + +-- ----------------------------------------------------------------------------- +-- Describe + +describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO () +describePackage verbosity my_flags pkgarg expand_pkgroot = do + (_, _, flag_db_stack) <- + getPkgDatabases verbosity False{-modify-} False{-use user-} + True{-use cache-} expand_pkgroot my_flags + dbs <- findPackagesByDB flag_db_stack pkgarg + doDump expand_pkgroot [ (pkg, locationAbsolute db) + | (db, pkgs) <- dbs, pkg <- pkgs ] + +dumpPackages :: Verbosity -> [Flag] -> Bool -> IO () +dumpPackages verbosity my_flags expand_pkgroot = do + (_, _, flag_db_stack) <- + getPkgDatabases verbosity False{-modify-} False{-use user-} + True{-use cache-} expand_pkgroot my_flags + doDump expand_pkgroot [ (pkg, locationAbsolute db) + | db <- flag_db_stack, pkg <- packages db ] + +doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO () +doDump expand_pkgroot pkgs = do + -- fix the encoding to UTF-8, since this is an interchange format + hSetEncoding stdout utf8 + putStrLn $ + intercalate "---\n" + [ if expand_pkgroot + then showInstalledPackageInfo pkg + else showInstalledPackageInfo pkg ++ pkgrootField + | (pkg, pkgloc) <- pkgs + , let pkgroot = takeDirectory pkgloc + pkgrootField = "pkgroot: " ++ show pkgroot ++ "\n" ] + +-- PackageId is can have globVersion for the version +findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo] +findPackages db_stack pkgarg + = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg + +findPackagesByDB :: PackageDBStack -> PackageArg + -> IO [(PackageDB, [InstalledPackageInfo])] +findPackagesByDB db_stack pkgarg + = case [ (db, matched) + | db <- db_stack, + let matched = filter (pkgarg `matchesPkg`) (packages db), + not (null matched) ] of + [] -> die ("cannot find package " ++ pkg_msg pkgarg) + ps -> return ps + where + pkg_msg (Id pkgid) = display pkgid + pkg_msg (PkgKey pk) = display pk + pkg_msg (IPId ipid) = display ipid + pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat + +matches :: PackageIdentifier -> PackageIdentifier -> Bool +pid `matches` pid' + = (pkgName pid == pkgName pid') + && (pkgVersion pid == pkgVersion pid' || not (realVersion pid)) + +realVersion :: PackageIdentifier -> Bool +realVersion pkgid = versionBranch (pkgVersion pkgid) /= [] + -- when versionBranch == [], this is a glob + +matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool +(Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg +(PkgKey pk) `matchesPkg` pkg = pk == packageKey pkg +(IPId ipid) `matchesPkg` pkg = ipid == installedPackageId pkg +(Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg)) + +-- ----------------------------------------------------------------------------- +-- Field + +describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO () +describeField verbosity my_flags pkgarg fields expand_pkgroot = do + (_, _, flag_db_stack) <- + getPkgDatabases verbosity False{-modify-} False{-use user-} + True{-use cache-} expand_pkgroot my_flags + fns <- mapM toField fields + ps <- findPackages flag_db_stack pkgarg + mapM_ (selectFields fns) ps + where showFun = if FlagSimpleOutput `elem` my_flags + then showSimpleInstalledPackageInfoField + else showInstalledPackageInfoField + toField f = case showFun f of + Nothing -> die ("unknown field: " ++ f) + Just fn -> return fn + selectFields fns pinfo = mapM_ (\fn->putStrLn (fn pinfo)) fns + + +-- ----------------------------------------------------------------------------- +-- Check: Check consistency of installed packages + +checkConsistency :: Verbosity -> [Flag] -> IO () +checkConsistency verbosity my_flags = do + (db_stack, _, _) <- + getPkgDatabases verbosity False{-modify-} True{-use user-} + True{-use cache-} True{-expand vars-} + my_flags + -- although check is not a modify command, we do need to use the user + -- db, because we may need it to verify package deps. + + let simple_output = FlagSimpleOutput `elem` my_flags + + let pkgs = allPackagesInStack db_stack + + checkPackage p = do + (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack + False True True + if null es + then do when (not simple_output) $ do + _ <- reportValidateErrors [] ws "" Nothing + return () + return [] + else do + when (not simple_output) $ do + reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":") + _ <- reportValidateErrors es ws " " Nothing + return () + return [p] + + broken_pkgs <- concat `fmap` mapM checkPackage pkgs + + let filterOut pkgs1 pkgs2 = filter not_in pkgs2 + where not_in p = sourcePackageId p `notElem` all_ps + all_ps = map sourcePackageId pkgs1 + + let not_broken_pkgs = filterOut broken_pkgs pkgs + (_, trans_broken_pkgs) = closure [] not_broken_pkgs + all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs + + when (not (null all_broken_pkgs)) $ do + if simple_output + then simplePackageList my_flags all_broken_pkgs + else do + reportError ("\nThe following packages are broken, either because they have a problem\n"++ + "listed above, or because they depend on a broken package.") + mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs + + when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1) + + +closure :: [InstalledPackageInfo] -> [InstalledPackageInfo] + -> ([InstalledPackageInfo], [InstalledPackageInfo]) +closure pkgs db_stack = go pkgs db_stack + where + go avail not_avail = + case partition (depsAvailable avail) not_avail of + ([], not_avail') -> (avail, not_avail') + (new_avail, not_avail') -> go (new_avail ++ avail) not_avail' + + depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo + -> Bool + depsAvailable pkgs_ok pkg = null dangling + where dangling = filter (`notElem` pids) (depends pkg) + pids = map installedPackageId pkgs_ok + + -- we want mutually recursive groups of package to show up + -- as broken. (#1750) + +brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo] +brokenPackages pkgs = snd (closure [] pkgs) + +----------------------------------------------------------------------------- +-- Sanity-check a new package config, and automatically build GHCi libs +-- if requested. + +type ValidateError = (Force,String) +type ValidateWarning = String + +newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) } + +instance Functor Validate where + fmap = liftM + +instance Applicative Validate where + pure = return + (<*>) = ap + +instance Monad Validate where + return a = V $ return (a, [], []) + m >>= k = V $ do + (a, es, ws) <- runValidate m + (b, es', ws') <- runValidate (k a) + return (b,es++es',ws++ws') + +verror :: Force -> String -> Validate () +verror f s = V (return ((),[(f,s)],[])) + +vwarn :: String -> Validate () +vwarn s = V (return ((),[],["Warning: " ++ s])) + +liftIO :: IO a -> Validate a +liftIO k = V (k >>= \a -> return (a,[],[])) + +-- returns False if we should die +reportValidateErrors :: [ValidateError] -> [ValidateWarning] + -> String -> Maybe Force -> IO Bool +reportValidateErrors es ws prefix mb_force = do + mapM_ (warn . (prefix++)) ws + oks <- mapM report es + return (and oks) + where + report (f,s) + | Just force <- mb_force + = if (force >= f) + then do reportError (prefix ++ s ++ " (ignoring)") + return True + else if f < CannotForce + then do reportError (prefix ++ s ++ " (use --force to override)") + return False + else do reportError err + return False + | otherwise = do reportError err + return False + where + err = prefix ++ s + +validatePackageConfig :: InstalledPackageInfo + -> Verbosity + -> PackageDBStack + -> Bool -- auto-ghc-libs + -> Bool -- multi_instance + -> Bool -- update, or check + -> Force + -> IO () +validatePackageConfig pkg verbosity db_stack auto_ghci_libs + multi_instance update force = do + (_,es,ws) <- runValidate $ + checkPackageConfig pkg verbosity db_stack + auto_ghci_libs multi_instance update + ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force) + when (not ok) $ exitWith (ExitFailure 1) + +checkPackageConfig :: InstalledPackageInfo + -> Verbosity + -> PackageDBStack + -> Bool -- auto-ghc-libs + -> Bool -- multi_instance + -> Bool -- update, or check + -> Validate () +checkPackageConfig pkg verbosity db_stack auto_ghci_libs + multi_instance update = do + checkInstalledPackageId pkg db_stack update + checkPackageId pkg + checkPackageKey pkg + checkDuplicates db_stack pkg multi_instance update + mapM_ (checkDep db_stack) (depends pkg) + checkDuplicateDepends (depends pkg) + mapM_ (checkDir False "import-dirs") (importDirs pkg) + mapM_ (checkDir True "library-dirs") (libraryDirs pkg) + mapM_ (checkDir True "include-dirs") (includeDirs pkg) + mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg) + mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg) + mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg) + checkDuplicateModules pkg + checkExposedModules db_stack pkg + checkOtherModules pkg + mapM_ (checkHSLib verbosity (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg) + -- ToDo: check these somehow? + -- extra_libraries :: [String], + -- c_includes :: [String], + +checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool + -> Validate () +checkInstalledPackageId ipi db_stack update = do + let ipid@(InstalledPackageId str) = installedPackageId ipi + when (null str) $ verror CannotForce "missing id field" + let dups = [ p | p <- allPackagesInStack db_stack, + installedPackageId p == ipid ] + when (not update && not (null dups)) $ + verror CannotForce $ + "package(s) with this id already exist: " ++ + unwords (map (display.packageId) dups) + +-- When the package name and version are put together, sometimes we can +-- end up with a package id that cannot be parsed. This will lead to +-- difficulties when the user wants to refer to the package later, so +-- we check that the package id can be parsed properly here. +checkPackageId :: InstalledPackageInfo -> Validate () +checkPackageId ipi = + let str = display (sourcePackageId ipi) in + case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of + [_] -> return () + [] -> verror CannotForce ("invalid package identifier: " ++ str) + _ -> verror CannotForce ("ambiguous package identifier: " ++ str) + +checkPackageKey :: InstalledPackageInfo -> Validate () +checkPackageKey ipi = + let str = display (packageKey ipi) in + case [ x :: PackageKey | (x,ys) <- readP_to_S parse str, all isSpace ys ] of + [_] -> return () + [] -> verror CannotForce ("invalid package key: " ++ str) + _ -> verror CannotForce ("ambiguous package key: " ++ str) + +checkDuplicates :: PackageDBStack -> InstalledPackageInfo + -> Bool -> Bool-> Validate () +checkDuplicates db_stack pkg multi_instance update = do + let + pkgid = sourcePackageId pkg + pkgs = packages (head db_stack) + -- + -- Check whether this package id already exists in this DB + -- + when (not update && not multi_instance + && (pkgid `elem` map sourcePackageId pkgs)) $ + verror CannotForce $ + "package " ++ display pkgid ++ " is already installed" + + let + uncasep = map toLower . display + dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs) + + when (not update && not (null dups)) $ verror ForceAll $ + "Package names may be treated case-insensitively in the future.\n"++ + "Package " ++ display pkgid ++ + " overlaps with: " ++ unwords (map display dups) + +checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate () +checkDir = checkPath False True +checkFile = checkPath False False +checkDirURL = checkPath True True + +checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate () +checkPath url_ok is_dir warn_only thisfield d + | url_ok && ("http://" `isPrefixOf` d + || "https://" `isPrefixOf` d) = return () + + | url_ok + , Just d' <- stripPrefix "file://" d + = checkPath False is_dir warn_only thisfield d' + + -- Note: we don't check for $topdir/${pkgroot} here. We rely on these + -- variables having been expanded already, see mungePackagePaths. + + | isRelative d = verror ForceFiles $ + thisfield ++ ": " ++ d ++ " is a relative path which " + ++ "makes no sense (as there is nothing for it to be " + ++ "relative to). You can make paths relative to the " + ++ "package database itself by using ${pkgroot}." + -- relative paths don't make any sense; #4134 + | otherwise = do + there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d + when (not there) $ + let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a " + ++ if is_dir then "directory" else "file" + in + if warn_only + then vwarn msg + else verror ForceFiles msg + +checkDep :: PackageDBStack -> InstalledPackageId -> Validate () +checkDep db_stack pkgid + | pkgid `elem` pkgids = return () + | otherwise = verror ForceAll ("dependency \"" ++ display pkgid + ++ "\" doesn't exist") + where + all_pkgs = allPackagesInStack db_stack + pkgids = map installedPackageId all_pkgs + +checkDuplicateDepends :: [InstalledPackageId] -> Validate () +checkDuplicateDepends deps + | null dups = return () + | otherwise = verror ForceAll ("package has duplicate dependencies: " ++ + unwords (map display dups)) + where + dups = [ p | (p:_:_) <- group (sort deps) ] + +checkHSLib :: Verbosity -> [String] -> Bool -> String -> Validate () +checkHSLib verbosity dirs auto_ghci_libs lib = do + let batch_lib_file = "lib" ++ lib ++ ".jslib" + filenames = ["lib" ++ lib ++ ".jslib", + "lib" ++ lib ++ ".jslib", + "lib" ++ lib ++ "-ghc" ++ showVersion ghcVersion ++ ".jslib", + "lib" ++ lib ++ "-ghc" ++ showVersion ghcVersion ++ ".jslib", + lib ++ "-ghc" ++ showVersion ghcVersion ++ ".jslib"] + m <- liftIO $ doesFileExistOnPath filenames dirs + case m of + Nothing -> verror ForceFiles ("cannot find any of " ++ show filenames ++ + " on library path") + Just dir -> liftIO $ checkGHCiLib verbosity dir batch_lib_file lib auto_ghci_libs + +doesFileExistOnPath :: [FilePath] -> [FilePath] -> IO (Maybe FilePath) +doesFileExistOnPath filenames paths = go fullFilenames + where fullFilenames = [ (path, path filename) + | filename <- filenames + , path <- paths ] + go [] = return Nothing + go ((p, fp) : xs) = do b <- doesFileExist fp + if b then return (Just p) else go xs + +-- | Perform validation checks (module file existence checks) on the +-- @hidden-modules@ field. +checkOtherModules :: InstalledPackageInfo -> Validate () +checkOtherModules pkg = mapM_ (checkModuleFile pkg) (hiddenModules pkg) + +-- | Perform validation checks (module file existence checks and module +-- reexport checks) on the @exposed-modules@ field. +checkExposedModules :: PackageDBStack -> InstalledPackageInfo -> Validate () +checkExposedModules db_stack pkg = + mapM_ checkExposedModule (exposedModules pkg) + where + checkExposedModule (ExposedModule modl reexport _sig) = do + let checkOriginal = checkModuleFile pkg modl + checkReexport = checkOriginalModule "module reexport" db_stack pkg + maybe checkOriginal checkReexport reexport + +-- | Validates the existence of an appropriate @hi@ file associated with +-- a module. Used for both @hidden-modules@ and @exposed-modules@ which +-- are not reexports. +checkModuleFile :: InstalledPackageInfo -> ModuleName -> Validate () +checkModuleFile pkg modl = + -- there's no interface file for GHC.Prim + unless (modl == ModuleName.fromString "GHC.Prim") $ do + let files = [ ModuleName.toFilePath modl <.> extension + | extension <- ["hi", "p_hi", "dyn_hi" ] ] + m <- liftIO $ doesFileExistOnPath files (importDirs pkg) + when (isNothing m) $ + verror ForceFiles ("cannot find any of " ++ show files) + +-- | Validates that @exposed-modules@ and @hidden-modules@ do not have duplicate +-- entries. +-- ToDo: this needs updating for signatures: signatures can validly show up +-- multiple times in the @exposed-modules@ list as long as their backing +-- implementations agree. +checkDuplicateModules :: InstalledPackageInfo -> Validate () +checkDuplicateModules pkg + | null dups = return () + | otherwise = verror ForceAll ("package has duplicate modules: " ++ + unwords (map display dups)) + where + dups = [ m | (m:_:_) <- group (sort mods) ] + mods = map exposedName (exposedModules pkg) ++ hiddenModules pkg + +-- | Validates an original module entry, either the origin of a module reexport +-- or the backing implementation of a signature, by checking that it exists, +-- really is an original definition, and is accessible from the dependencies of +-- the package. +-- ToDo: If the original module in question is a backing signature +-- implementation, then we should also check that the original module in +-- question is NOT a signature (however, if it is a reexport, then it's fine +-- for the original module to be a signature.) +checkOriginalModule :: String + -> PackageDBStack + -> InstalledPackageInfo + -> OriginalModule + -> Validate () +checkOriginalModule fieldName db_stack pkg + (OriginalModule definingPkgId definingModule) = + let mpkg = if definingPkgId == installedPackageId pkg + then Just pkg + else PackageIndex.lookupInstalledPackageId ipix definingPkgId + in case mpkg of + Nothing + -> verror ForceAll (fieldName ++ " refers to a non-existent " ++ + "defining package: " ++ + display definingPkgId) + + Just definingPkg + | not (isIndirectDependency definingPkgId) + -> verror ForceAll (fieldName ++ " refers to a defining " ++ + "package that is not a direct (or indirect) " ++ + "dependency of this package: " ++ + display definingPkgId) + + | otherwise + -> case find ((==definingModule).exposedName) + (exposedModules definingPkg) of + Nothing -> + verror ForceAll (fieldName ++ " refers to a module " ++ + display definingModule ++ " " ++ + "that is not exposed in the " ++ + "defining package " ++ display definingPkgId) + Just (ExposedModule {exposedReexport = Just _} ) -> + verror ForceAll (fieldName ++ " refers to a module " ++ + display definingModule ++ " " ++ + "that is reexported but not defined in the " ++ + "defining package " ++ display definingPkgId) + _ -> return () + + where + all_pkgs = allPackagesInStack db_stack + ipix = PackageIndex.fromList all_pkgs + + isIndirectDependency pkgid = fromMaybe False $ do + thispkg <- graphVertex (installedPackageId pkg) + otherpkg <- graphVertex pkgid + return (Graph.path depgraph thispkg otherpkg) + (depgraph, _, graphVertex) = + PackageIndex.dependencyGraph (PackageIndex.insert pkg ipix) + + +checkGHCiLib :: Verbosity -> String -> String -> String -> Bool -> IO () +checkGHCiLib verbosity batch_lib_dir batch_lib_file lib auto_build + | auto_build = autoBuildGHCiLib verbosity batch_lib_dir batch_lib_file ghci_lib_file + | otherwise = return () + where + ghci_lib_file = lib <.> "o" + +-- automatically build the GHCi version of a batch lib, +-- using ld --whole-archive. + +autoBuildGHCiLib :: Verbosity -> String -> String -> String -> IO () +autoBuildGHCiLib verbosity dir batch_file ghci_file = do + let ghci_lib_file = dir ++ '/':ghci_file + batch_lib_file = dir ++ '/':batch_file + when (verbosity >= Normal) $ + info ("building GHCi library " ++ ghci_lib_file ++ "...") +#if defined(darwin_HOST_OS) + r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file] +#elif defined(mingw32_HOST_OS) + execDir <- getLibDir + r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file] +#else + r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file] +#endif + when (r /= ExitSuccess) $ exitWith r + when (verbosity >= Normal) $ + infoLn (" done.") + +-- ----------------------------------------------------------------------------- +-- Searching for modules + +#if not_yet + +findModules :: [FilePath] -> IO [String] +findModules paths = + mms <- mapM searchDir paths + return (concat mms) + +searchDir path prefix = do + fs <- getDirectoryEntries path `catchIO` \_ -> return [] + searchEntries path prefix fs + +searchEntries path prefix [] = return [] +searchEntries path prefix (f:fs) + | looks_like_a_module = do + ms <- searchEntries path prefix fs + return (prefix `joinModule` f : ms) + | looks_like_a_component = do + ms <- searchDir (path f) (prefix `joinModule` f) + ms' <- searchEntries path prefix fs + return (ms ++ ms') + | otherwise + searchEntries path prefix fs + + where + (base,suffix) = splitFileExt f + looks_like_a_module = + suffix `elem` haskell_suffixes && + all okInModuleName base + looks_like_a_component = + null suffix && all okInModuleName base + +okInModuleName c + +#endif + +-- --------------------------------------------------------------------------- +-- expanding environment variables in the package configuration + +expandEnvVars :: String -> Force -> IO String +expandEnvVars str0 force = go str0 "" + where + go "" acc = return $! reverse acc + go ('$':'{':str) acc | (var, '}':rest) <- break close str + = do value <- lookupEnvVar var + go rest (reverse value ++ acc) + where close c = c == '}' || c == '\n' -- don't span newlines + go (c:str) acc + = go str (c:acc) + + lookupEnvVar :: String -> IO String + lookupEnvVar "pkgroot" = return "${pkgroot}" -- these two are special, + lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them + lookupEnvVar nm = + catchIO (System.Environment.getEnv nm) + (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++ + show nm) + return "") + +----------------------------------------------------------------------------- + +getProgramName :: IO String +getProgramName = liftM (`withoutSuffix` ".bin") getProgName + where str `withoutSuffix` suff + | suff `isSuffixOf` str = take (length str - length suff) str + | otherwise = str + +bye :: String -> IO a +bye s = putStr s >> exitWith ExitSuccess + +die :: String -> IO a +die = dieWith 1 + +dieWith :: Int -> String -> IO a +dieWith ec s = do + prog <- getProgramName + reportError (prog ++ ": " ++ s) + exitWith (ExitFailure ec) + +dieOrForceAll :: Force -> String -> IO () +dieOrForceAll ForceAll s = ignoreError s +dieOrForceAll _other s = dieForcible s + +warn :: String -> IO () +warn = reportError + +-- send info messages to stdout +infoLn :: String -> IO () +infoLn = putStrLn + +info :: String -> IO () +info = putStr + +ignoreError :: String -> IO () +ignoreError s = reportError (s ++ " (ignoring)") + +reportError :: String -> IO () +reportError s = do hFlush stdout; hPutStrLn stderr s + +dieForcible :: String -> IO () +dieForcible s = die (s ++ " (use --force to override)") + +my_head :: String -> [a] -> a +my_head s [] = error s +my_head _ (x : _) = x + +getLibDir :: IO (Maybe String) +getLibDir = return $ Just hasteSysDir + +----------------------------------------- +-- Adapted from ghc/compiler/utils/Panic + +installSignalHandlers :: IO () +installSignalHandlers = do + threadid <- myThreadId + let + interrupt = Exception.throwTo threadid + (Exception.ErrorCall "interrupted") + -- +#if !defined(mingw32_HOST_OS) + _ <- installHandler sigQUIT (Catch interrupt) Nothing + _ <- installHandler sigINT (Catch interrupt) Nothing + return () +#else + -- GHC 6.3+ has support for console events on Windows + -- NOTE: running GHCi under a bash shell for some reason requires + -- you to press Ctrl-Break rather than Ctrl-C to provoke + -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know + -- why --SDM 17/12/2004 + let sig_handler ControlC = interrupt + sig_handler Break = interrupt + sig_handler _ = return () + + _ <- installHandler (Catch sig_handler) + return () +#endif + +#if mingw32_HOST_OS || mingw32_TARGET_OS +throwIOIO :: Exception.IOException -> IO a +throwIOIO = Exception.throwIO +#endif + +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +catchIO = Exception.catch + +tryIO :: IO a -> IO (Either Exception.IOException a) +tryIO = Exception.try + +writeFileUtf8Atomic :: FilePath -> String -> IO () +writeFileUtf8Atomic targetFile content = + withFileAtomic targetFile $ \h -> do + hSetEncoding h utf8 + hPutStr h content + +-- copied from Cabal's Distribution.Simple.Utils, except that we want +-- to use text files here, rather than binary files. +withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO () +withFileAtomic targetFile write_content = do + (newFile, newHandle) <- openNewFile targetDir template + do write_content newHandle + hClose newHandle +#if mingw32_HOST_OS || mingw32_TARGET_OS + renameFile newFile targetFile + -- If the targetFile exists then renameFile will fail + `catchIO` \err -> do + exists <- doesFileExist targetFile + if exists + then do removeFileSafe targetFile + -- Big fat hairy race condition + renameFile newFile targetFile + -- If the removeFile succeeds and the renameFile fails + -- then we've lost the atomic property. + else throwIOIO err +#else + renameFile newFile targetFile +#endif + `Exception.onException` do hClose newHandle + removeFileSafe newFile + where + template = targetName <.> "tmp" + targetDir | null targetDir_ = "." + | otherwise = targetDir_ + --TODO: remove this when takeDirectory/splitFileName is fixed + -- to always return a valid dir + (targetDir_,targetName) = splitFileName targetFile + +openNewFile :: FilePath -> String -> IO (FilePath, Handle) +openNewFile dir template = do + -- this was added to System.IO in 6.12.1 + -- we must use this version because the version below opens the file + -- in binary mode. + openTempFileWithDefaultPermissions dir template + +readUTF8File :: FilePath -> IO String +readUTF8File file = do + h <- openFile file ReadMode + -- fix the encoding to UTF-8 + hSetEncoding h utf8 + hGetContents h + +-- removeFileSave doesn't throw an exceptions, if the file is already deleted +removeFileSafe :: FilePath -> IO () +removeFileSafe fn = + removeFile fn `catchIO` \ e -> + when (not $ isDoesNotExistError e) $ ioError e + +absolutePath :: FilePath -> IO FilePath +absolutePath path = return . normalise . ( path) =<< getCurrentDirectory + +-- | Only global packages may be marked as relocatable! +-- May break horribly for general use, only reliable for Haste base packages. +relocate :: [String] -> String -> Sh.Shell () +relocate packages pkg = do + pi <- Sh.run hastePkgBinary (packages ++ ["describe", pkg]) "" + Sh.run_ hastePkgBinary (packages ++ ["update", "-", "--force", "--global"]) + (reloc pi) + where + reloc = unlines . map fixPath . lines + + fixPath s + | isKey "library-dirs: " s = prefix s "library-dirs" importDir + | isKey "import-dirs: " s = prefix s "import-dirs" importDir + | isKey "haddock-interfaces: " s = prefix s "haddock-interfaces" importDir + | isKey "haddock-html: " s = prefix s "haddock-html" importDir + | isKey "include-dirs: " s = "include-dirs: " ++ includeDir + | otherwise = s + + prefix s pfx path = pfx ++ ": " ++ path stripPrefix s + + stripPrefix = joinPath . dropWhile (not . isKey pkg) . splitPath + + isKey _ "" = + False + isKey key str = + and $ zipWith (==) key str + + importDir = "${pkgroot}" + includeDir = "${pkgroot}" "include" + + +{- Note [writeAtomic leaky abstraction] +GhcPkg.writePackageDb calls writeAtomic, which first writes to a temp file, +and then moves the tempfile to its final destination. This all happens in the +same directory (package.conf.d). +Moving a file doesn't change its modification time, but it *does* change the +modification time of the directory it is placed in. Since we compare the +modification time of the cache file to that of the directory it is in to +decide whether the cache is out-of-date, it will be instantly out-of-date +after creation, if the renaming takes longer than the smallest time difference +that the getModificationTime can measure. + +The solution we opt for is a "touch" of the cache file right after it is +created. This resets the modification time of the cache file and the directory +to the current time. + +Other possible solutions: + * backdate the modification time of the directory to the modification time + of the cachefile. This is what we used to do on posix platforms. An + observer of the directory would see the modification time of the directory + jump back in time. Not nice, although in practice probably not a problem. + Also note that a cross-platform implementation of setModificationTime is + currently not available. + * set the modification time of the cache file to the modification time of + the directory (instead of the curent time). This could also work, + given that we are the only ones writing to this directory. It would also + require a high-precision getModificationTime (lower precision times get + rounded down it seems), or the cache would still be out-of-date. + * change writeAtomic to create the tempfile outside of the target file's + directory. + * create the cachefile outside of the package.conf.d directory in the first + place. But there are tests and there might be tools that currently rely on + the package.conf.d/package.cache format. +-} diff --git a/utils/haste-pkg/haste-pkg.hs b/utils/haste-pkg/haste-pkg.hs --- a/utils/haste-pkg/haste-pkg.hs +++ b/utils/haste-pkg/haste-pkg.hs @@ -1,1831 +1,10 @@ -{-# LANGUAGE PatternGuards, CPP, ForeignFunctionInterface #-} ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow 2004-2009. --- --- Package management tool --- ------------------------------------------------------------------------------ - -module Main (main) where - -import Distribution.InstalledPackageInfo.Binary() -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.ModuleName hiding (main) -import Distribution.InstalledPackageInfo -import Distribution.Compat.ReadP -import Distribution.ParseUtils -import Distribution.Package hiding (depends) -import Distribution.Text -import Distribution.Version -import System.FilePath as FilePath -import qualified System.FilePath.Posix as FilePath.Posix -import System.Process -import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing, - getModificationTime ) -import Text.Printf - -import Prelude - -import System.Console.GetOpt -import qualified Control.Exception as Exception -import Data.Maybe - -import Data.Char ( isSpace, toLower ) -import Data.Ord (comparing) -import Control.Applicative (Applicative(..)) -import Control.Monad -import System.Directory ( doesDirectoryExist, getDirectoryContents, - doesFileExist, renameFile, removeFile, - getCurrentDirectory ) -import System.Exit ( exitWith, ExitCode(..) ) -import System.Environment ( getArgs, getProgName, getEnv ) -import System.IO -import System.IO.Error -import Data.List -import Control.Concurrent - -import qualified Data.ByteString.Lazy as B -import qualified Data.Binary as Bin -import qualified Data.Binary.Get as Bin - --- Haste-specific -import Haste.Environment -import Haste.Version -import System.Info (os) -import qualified Control.Shell as Sh - -#if defined(mingw32_HOST_OS) --- mingw32 needs these for getExecDir -import Foreign -import Foreign.C -#endif - -#ifdef mingw32_HOST_OS -import GHC.ConsoleHandler -#else -import System.Posix hiding (fdToHandle) -#endif - -#if defined(GLOB) -import qualified System.Info(os) -#endif - -#if !defined(mingw32_HOST_OS) && !defined(BOOTSTRAPPING) -import System.Console.Terminfo as Terminfo -#endif - -#ifdef mingw32_HOST_OS -# if defined(i386_HOST_ARCH) -# define WINDOWS_CCONV stdcall -# elif defined(x86_64_HOST_ARCH) -# define WINDOWS_CCONV ccall -# else -# error Unknown mingw32 arch -# endif -#endif - --- ----------------------------------------------------------------------------- --- Entry point - -main :: IO () -main = do - args <- getArgs - - case args of - ["relocate", pkg] -> do - Sh.shell (relocate packages pkg) >> exitWith ExitSuccess - _ -> - return () - - case getOpt Permute (flags ++ deprecFlags) args of - (cli,_,[]) | FlagHelp `elem` cli -> do - prog <- getProgramName - bye (usageInfo (usageHeader prog) flags) - (cli,_,[]) | FlagVersion `elem` cli -> - bye ourCopyright - (cli,nonopts,[]) -> - case getVerbosity Normal cli of - Right v -> runit v cli nonopts - Left err -> die err - (_,_,errors) -> do - prog <- getProgramName - die (concat errors ++ shortUsage prog) - where - packages = ["--global-package-db=" ++ pkgSysDir, - "--package-db=" ++ pkgSysDir, - "--package-db=" ++ pkgUserDir] - --- ----------------------------------------------------------------------------- --- Command-line syntax - -data Flag - = FlagUser - | FlagGlobal - | FlagHelp - | FlagVersion - | FlagConfig FilePath - | FlagGlobalConfig FilePath - | FlagForce - | FlagForceFiles - | FlagAutoGHCiLibs - | FlagExpandEnvVars - | FlagExpandPkgroot - | FlagNoExpandPkgroot - | FlagSimpleOutput - | FlagNamesOnly - | FlagIgnoreCase - | FlagNoUserDb - | FlagVerbosity (Maybe String) - deriving Eq - -flags :: [OptDescr Flag] -flags = [ - Option [] ["user"] (NoArg FlagUser) - "use the current user's package database", - Option [] ["global"] (NoArg FlagGlobal) - "use the global package database", - Option ['f'] ["package-db"] (ReqArg FlagConfig "FILE/DIR") - "use the specified package database", - Option [] ["package-conf"] (ReqArg FlagConfig "FILE/DIR") - "use the specified package database (DEPRECATED)", - Option [] ["global-package-db"] (ReqArg FlagGlobalConfig "DIR") - "location of the global package database", - Option [] ["no-user-package-db"] (NoArg FlagNoUserDb) - "never read the user package database", - Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb) - "never read the user package database (DEPRECATED)", - Option [] ["force"] (NoArg FlagForce) - "ignore missing dependencies, directories, and libraries", - Option [] ["force-files"] (NoArg FlagForceFiles) - "ignore missing directories and libraries only", - Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs) - "automatically build libs for GHCi (with register)", - Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars) - "expand environment variables (${name}-style) in input package descriptions", - Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot) - "expand ${pkgroot}-relative paths to absolute in output package descriptions", - Option [] ["no-expand-pkgroot"] (NoArg FlagNoExpandPkgroot) - "preserve ${pkgroot}-relative paths in output package descriptions", - Option ['?'] ["help"] (NoArg FlagHelp) - "display this help and exit", - Option ['V'] ["version"] (NoArg FlagVersion) - "output version information and exit", - Option [] ["simple-output"] (NoArg FlagSimpleOutput) - "print output in easy-to-parse format for some commands", - Option [] ["names-only"] (NoArg FlagNamesOnly) - "only print package names, not versions; can only be used with list --simple-output", - Option [] ["ignore-case"] (NoArg FlagIgnoreCase) - "ignore case for substring matching", - Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity") - "verbosity level (0-2, default 1)" - ] - -data Verbosity = Silent | Normal | Verbose - deriving (Show, Eq, Ord) - -getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity -getVerbosity v [] = Right v -getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs -getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs -getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs -getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs -getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v) -getVerbosity v (_ : fs) = getVerbosity v fs - -deprecFlags :: [OptDescr Flag] -deprecFlags = [ - -- put deprecated flags here - ] - -ourCopyright :: String -ourCopyright = "Haste package manager version " ++ showVersion ghcVersion ++ "\n" - -shortUsage :: String -> String -shortUsage prog = "For usage information see '" ++ prog ++ " --help'." - -usageHeader :: String -> String -usageHeader prog = substProg prog $ - "Usage:\n" ++ - " $p init {path}\n" ++ - " Create and initialise a package database at the location {path}.\n" ++ - " Packages can be registered in the new database using the register\n" ++ - " command with --package-db={path}. To use the new database with GHC,\n" ++ - " use GHC's -package-db flag.\n" ++ - "\n" ++ - " $p register {filename | -}\n" ++ - " Register the package using the specified installed package\n" ++ - " description. The syntax for the latter is given in the $p\n" ++ - " documentation. The input file should be encoded in UTF-8.\n" ++ - "\n" ++ - " $p update {filename | -}\n" ++ - " Register the package, overwriting any other package with the\n" ++ - " same name. The input file should be encoded in UTF-8.\n" ++ - "\n" ++ - " $p unregister {pkg-id}\n" ++ - " Unregister the specified package.\n" ++ - "\n" ++ - " $p expose {pkg-id}\n" ++ - " Expose the specified package.\n" ++ - "\n" ++ - " $p hide {pkg-id}\n" ++ - " Hide the specified package.\n" ++ - "\n" ++ - " $p trust {pkg-id}\n" ++ - " Trust the specified package.\n" ++ - "\n" ++ - " $p distrust {pkg-id}\n" ++ - " Distrust the specified package.\n" ++ - "\n" ++ - " $p list [pkg]\n" ++ - " List registered packages in the global database, and also the\n" ++ - " user database if --user is given. If a package name is given\n" ++ - " all the registered versions will be listed in ascending order.\n" ++ - " Accepts the --simple-output flag.\n" ++ - "\n" ++ - " $p dot\n" ++ - " Generate a graph of the package dependencies in a form suitable\n" ++ - " for input for the graphviz tools. For example, to generate a PDF" ++ - " of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++ - "\n" ++ - " $p find-module {module}\n" ++ - " List registered packages exposing module {module} in the global\n" ++ - " database, and also the user database if --user is given.\n" ++ - " All the registered versions will be listed in ascending order.\n" ++ - " Accepts the --simple-output flag.\n" ++ - "\n" ++ - " $p latest {pkg-id}\n" ++ - " Prints the highest registered version of a package.\n" ++ - "\n" ++ - " $p check\n" ++ - " Check the consistency of package dependencies and list broken packages.\n" ++ - " Accepts the --simple-output flag.\n" ++ - "\n" ++ - " $p describe {pkg}\n" ++ - " Give the registered description for the specified package. The\n" ++ - " description is returned in precisely the syntax required by $p\n" ++ - " register.\n" ++ - "\n" ++ - " $p field {pkg} {field}\n" ++ - " Extract the specified field of the package description for the\n" ++ - " specified package. Accepts comma-separated multiple fields.\n" ++ - "\n" ++ - " $p dump\n" ++ - " Dump the registered description for every package. This is like\n" ++ - " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++ - " by tools that parse the results, rather than humans. The output is\n" ++ - " always encoded in UTF-8, regardless of the current locale.\n" ++ - "\n" ++ - " $p recache\n" ++ - " Regenerate the package database cache. This command should only be\n" ++ - " necessary if you added a package to the database by dropping a file\n" ++ - " into the database directory manually. By default, the global DB\n" ++ - " is recached; to recache a different DB use --user or --package-db\n" ++ - " as appropriate.\n" ++ - "\n" ++ - " Substring matching is supported for {module} in find-module and\n" ++ - " for {pkg} in list, describe, and field, where a '*' indicates\n" ++ - " open substring ends (prefix*, *suffix, *infix*).\n" ++ - "\n" ++ - " When asked to modify a database (register, unregister, update,\n"++ - " hide, expose, and also check), ghc-pkg modifies the global database by\n"++ - " default. Specifying --user causes it to act on the user database,\n"++ - " or --package-db can be used to act on another database\n"++ - " entirely. When multiple of these options are given, the rightmost\n"++ - " one is used as the database to act upon.\n"++ - "\n"++ - " Commands that query the package database (list, tree, latest, describe,\n"++ - " field) operate on the list of databases specified by the flags\n"++ - " --user, --global, and --package-db. If none of these flags are\n"++ - " given, the default is --global --user.\n"++ - "\n" ++ - " The following optional flags are also accepted:\n" - -substProg :: String -> String -> String -substProg _ [] = [] -substProg prog ('$':'p':xs) = prog ++ substProg prog xs -substProg prog (c:xs) = c : substProg prog xs - --- ----------------------------------------------------------------------------- --- Do the business - -data Force = NoForce | ForceFiles | ForceAll | CannotForce - deriving (Eq,Ord) - -data PackageArg = Id PackageIdentifier | Substring String (String->Bool) - -runit :: Verbosity -> [Flag] -> [String] -> IO () -runit verbosity cli nonopts = do - installSignalHandlers -- catch ^C and clean up - prog <- getProgramName - let - force - | FlagForce `elem` cli = ForceAll - | FlagForceFiles `elem` cli = ForceFiles - | otherwise = NoForce - auto_ghci_libs = FlagAutoGHCiLibs `elem` cli - expand_env_vars= FlagExpandEnvVars `elem` cli - mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli - where accumExpandPkgroot _ FlagExpandPkgroot = Just True - accumExpandPkgroot _ FlagNoExpandPkgroot = Just False - accumExpandPkgroot x _ = x - - splitFields fields = unfoldr splitComma (',':fields) - where splitComma "" = Nothing - splitComma fs = Just $ break (==',') (tail fs) - - substringCheck :: String -> Maybe (String -> Bool) - substringCheck "" = Nothing - substringCheck "*" = Just (const True) - substringCheck [_] = Nothing - substringCheck (h:t) = - case (h, init t, last t) of - ('*',s,'*') -> Just (isInfixOf (f s) . f) - ('*',_, _ ) -> Just (isSuffixOf (f t) . f) - ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f) - _ -> Nothing - where f | FlagIgnoreCase `elem` cli = map toLower - | otherwise = id -#if defined(GLOB) - glob x | System.Info.os=="mingw32" = do - -- glob echoes its argument, after win32 filename globbing - (_,o,_,_) <- runInteractiveCommand ("glob "++x) - txt <- hGetContents o - return (read txt) - glob x | otherwise = return [x] -#endif - -- - -- first, parse the command - case nonopts of -#if defined(GLOB) - -- dummy command to demonstrate usage and permit testing - -- without messing things up; use glob to selectively enable - -- windows filename globbing for file parameters - -- register, update, FlagGlobalConfig, FlagConfig; others? - ["glob", filename] -> do - print filename - glob filename >>= print -#endif - ["init", filename] -> - initPackageDB filename verbosity cli - ["register", filename] -> - registerPackage filename verbosity cli - auto_ghci_libs expand_env_vars False force - ["update", filename] -> - registerPackage filename verbosity cli - auto_ghci_libs expand_env_vars True force - ["unregister", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - unregisterPackage pkgid verbosity cli force - ["expose", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - exposePackage pkgid verbosity cli force - ["hide", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - hidePackage pkgid verbosity cli force - ["trust", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - trustPackage pkgid verbosity cli force - ["distrust", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - distrustPackage pkgid verbosity cli force - ["list"] -> do - listPackages verbosity cli Nothing Nothing - ["list", pkgid_str] -> - case substringCheck pkgid_str of - Nothing -> do pkgid <- readGlobPkgId pkgid_str - listPackages verbosity cli (Just (Id pkgid)) Nothing - Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing - ["dot"] -> do - showPackageDot verbosity cli - ["find-module", moduleName] -> do - let match = maybe (==moduleName) id (substringCheck moduleName) - listPackages verbosity cli Nothing (Just match) - ["latest", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - latestPackage verbosity cli pkgid - ["describe", pkgid_str] -> do - pkgarg <- case substringCheck pkgid_str of - Nothing -> liftM Id (readGlobPkgId pkgid_str) - Just m -> return (Substring pkgid_str m) - describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot) - - ["field", pkgid_str, fields] -> do - pkgarg <- case substringCheck pkgid_str of - Nothing -> liftM Id (readGlobPkgId pkgid_str) - Just m -> return (Substring pkgid_str m) - describeField verbosity cli pkgarg - (splitFields fields) (fromMaybe True mexpand_pkgroot) - - ["check"] -> do - checkConsistency verbosity cli - - ["dump"] -> do - dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot) - - ["recache"] -> do - recache verbosity cli - - [] -> do - die ("missing command\n" ++ shortUsage prog) - (_cmd:_) -> do - die ("command-line syntax error\n" ++ shortUsage prog) - -parseCheck :: ReadP a a -> String -> String -> IO a -parseCheck parser str what = - case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of - [x] -> return x - _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what) - -readGlobPkgId :: String -> IO PackageIdentifier -readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier" - -parseGlobPackageId :: ReadP r PackageIdentifier -parseGlobPackageId = - parse - +++ - (do n <- parse - _ <- string "-*" - return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion })) - --- globVersion means "all versions" -globVersion :: Version -globVersion = Version{ versionBranch=[], versionTags=["*"] } - --- ----------------------------------------------------------------------------- --- Package databases - --- Some commands operate on a single database: --- register, unregister, expose, hide, trust, distrust --- however these commands also check the union of the available databases --- in order to check consistency. For example, register will check that --- dependencies exist before registering a package. --- --- Some commands operate on multiple databases, with overlapping semantics: --- list, describe, field - -data PackageDB - = PackageDB { - location, locationAbsolute :: !FilePath, - -- We need both possibly-relative and definately-absolute package - -- db locations. This is because the relative location is used as - -- an identifier for the db, so it is important we do not modify it. - -- On the other hand we need the absolute path in a few places - -- particularly in relation to the ${pkgroot} stuff. - - packages :: [InstalledPackageInfo] - } - -type PackageDBStack = [PackageDB] - -- A stack of package databases. Convention: head is the topmost - -- in the stack. - -allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo] -allPackagesInStack = concatMap packages - -getPkgDatabases :: Verbosity - -> Bool -- we are modifying, not reading - -> Bool -- read caches, if available - -> Bool -- expand vars, like ${pkgroot} and $topdir - -> [Flag] - -> IO (PackageDBStack, - -- the real package DB stack: [global,user] ++ - -- DBs specified on the command line with -f. - Maybe FilePath, - -- which one to modify, if any - PackageDBStack) - -- the package DBs specified on the command - -- line, or [global,user] otherwise. This - -- is used as the list of package DBs for - -- commands that just read the DB, such as 'list'. - -getPkgDatabases verbosity modify use_cache expand_vars my_flags = do - -- first we determine the location of the global package config. On Windows, - -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the - -- location is passed to the binary using the --global-package-db flag by the - -- wrapper script. - let err_msg = "missing --global-package-db option, location of global package database unknown\n" - global_conf <- - case [ f | FlagGlobalConfig f <- my_flags ] of - [] -> do mb_dir <- getLibDir - case mb_dir of - Nothing -> die err_msg - Just dir -> do - r <- lookForPackageDBIn dir - case r of - Nothing -> die ("Can't find package database in " ++ dir) - Just path -> return path - fs -> return (last fs) - - -- The value of the $topdir variable used in some package descriptions - -- Note that the way we calculate this is slightly different to how it - -- is done in ghc itself. We rely on the convention that the global - -- package db lives in ghc's libdir. - top_dir <- absolutePath (takeDirectory global_conf) - - let no_user_db = FlagNoUserDb `elem` my_flags - - mb_user_conf <- - if no_user_db then return Nothing else do - r <- lookForPackageDBIn hasteUserDir - case r of - Nothing -> return (Just (pkgUserDir, False)) - Just f -> return (Just (f, True)) - - -- If the user database doesn't exist, and this command isn't a - -- "modify" command, then we won't attempt to create or use it. - let sys_databases - | Just (user_conf,user_exists) <- mb_user_conf, - modify || user_exists = [user_conf, global_conf] - | otherwise = [global_conf] - - e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH") - let env_stack = - case e_pkg_path of - Left _ -> sys_databases - Right path - | last cs == "" -> init cs ++ sys_databases - | otherwise -> cs - where cs = parseSearchPath path - - -- The "global" database is always the one at the bottom of the stack. - -- This is the database we modify by default. - virt_global_conf = last env_stack - - let db_flags = [ f | Just f <- map is_db_flag my_flags ] - where is_db_flag FlagUser - | Just (user_conf, _user_exists) <- mb_user_conf - = Just user_conf - is_db_flag FlagGlobal = Just virt_global_conf - is_db_flag (FlagConfig f) = Just f - is_db_flag _ = Nothing - - let flag_db_names | null db_flags = env_stack - | otherwise = reverse (nub db_flags) - - -- For a "modify" command, treat all the databases as - -- a stack, where we are modifying the top one, but it - -- can refer to packages in databases further down the - -- stack. - - -- -f flags on the command line add to the database - -- stack, unless any of them are present in the stack - -- already. - let final_stack = filter (`notElem` env_stack) - [ f | FlagConfig f <- reverse my_flags ] - ++ env_stack - - -- the database we actually modify is the one mentioned - -- rightmost on the command-line. - let to_modify - | not modify = Nothing - | null db_flags = Just virt_global_conf - | otherwise = Just (last db_flags) - - db_stack <- sequence - [ do db <- readParseDatabase verbosity mb_user_conf use_cache db_path - if expand_vars then return (mungePackageDBPaths top_dir db) - else return db - | db_path <- final_stack ] - - let flag_db_stack = [ db | db_name <- flag_db_names, - db <- db_stack, location db == db_name ] - - return (db_stack, to_modify, flag_db_stack) - - -lookForPackageDBIn :: FilePath -> IO (Maybe FilePath) -lookForPackageDBIn dir = do - let path_dir = dir "package.conf.d" - exists_dir <- doesDirectoryExist path_dir - if exists_dir then return (Just path_dir) else do - let path_file = dir "package.conf" - exists_file <- doesFileExist path_file - if exists_file then return (Just path_file) else return Nothing - -readParseDatabase :: Verbosity - -> Maybe (FilePath,Bool) - -> Bool -- use cache - -> FilePath - -> IO PackageDB - -readParseDatabase verbosity mb_user_conf use_cache path - -- the user database (only) is allowed to be non-existent - | Just (user_conf,False) <- mb_user_conf, path == user_conf - = mkPackageDB [] - | otherwise - = do e <- tryIO $ getDirectoryContents path - case e of - Left _ -> do - pkgs <- parseMultiPackageConf verbosity path - mkPackageDB pkgs - Right fs - | not use_cache -> ignore_cache (const $ return ()) - | otherwise -> do - let cache = path cachefilename - tdir <- getModificationTime path - e_tcache <- tryIO $ getModificationTime cache - case e_tcache of - Left ex -> do - when (verbosity > Normal) $ - warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex) - ignore_cache (const $ return ()) - Right tcache -> do - let compareTimestampToCache file = - when (verbosity >= Verbose) $ do - tFile <- getModificationTime file - compareTimestampToCache' file tFile - compareTimestampToCache' file tFile = do - let rel = case tcache `compare` tFile of - LT -> " (NEWER than cache)" - GT -> " (older than cache)" - EQ -> " (same as cache)" - warn ("Timestamp " ++ show tFile - ++ " for " ++ file ++ rel) - when (verbosity >= Verbose) $ do - warn ("Timestamp " ++ show tcache ++ " for " ++ cache) - compareTimestampToCache' path tdir - if tcache >= tdir - then do - when (verbosity > Normal) $ - infoLn ("using cache: " ++ cache) - pkgs <- myReadBinPackageDB cache - let pkgs' = map convertPackageInfoIn pkgs - mkPackageDB pkgs' - else do - when (verbosity >= Normal) $ do - warn ("WARNING: cache is out of date: " - ++ cache) - warn "Use 'ghc-pkg recache' to fix." - ignore_cache compareTimestampToCache - where - ignore_cache :: (FilePath -> IO ()) -> IO PackageDB - ignore_cache checkTime = do - let confs = filter (".conf" `isSuffixOf`) fs - doFile f = do checkTime f - parseSingletonPackageConf verbosity f - pkgs <- mapM doFile $ map (path ) confs - mkPackageDB pkgs - where - mkPackageDB pkgs = do - path_abs <- absolutePath path - return PackageDB { - location = path, - locationAbsolute = path_abs, - packages = pkgs - } - --- read the package.cache file strictly, to work around a problem with --- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed --- after it has been completely read, leading to a sharing violation --- later. -myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString] -myReadBinPackageDB filepath = do - h <- openBinaryFile filepath ReadMode - sz <- hFileSize h - b <- B.hGet h (fromIntegral sz) - hClose h - return $ Bin.runGet Bin.get b - -parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo] -parseMultiPackageConf verbosity file = do - when (verbosity > Normal) $ infoLn ("reading package database: " ++ file) - str <- readUTF8File file - let pkgs = map convertPackageInfoIn $ read str - Exception.evaluate pkgs - `catchError` \e-> - die ("error while parsing " ++ file ++ ": " ++ show e) - -parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo -parseSingletonPackageConf verbosity file = do - when (verbosity > Normal) $ infoLn ("reading package config: " ++ file) - readUTF8File file >>= fmap fst . parsePackageInfo - -cachefilename :: FilePath -cachefilename = "package.cache" - -mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB -mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } = - db { packages = map (mungePackagePaths top_dir pkgroot) pkgs } - where - pkgroot = takeDirectory (locationAbsolute db) - -- It so happens that for both styles of package db ("package.conf" - -- files and "package.conf.d" dirs) the pkgroot is the parent directory - -- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/ - --- TODO: This code is duplicated in compiler/main/Packages.lhs -mungePackagePaths :: FilePath -> FilePath - -> InstalledPackageInfo -> InstalledPackageInfo --- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec --- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) --- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. --- The "pkgroot" is the directory containing the package database. --- --- Also perform a similar substitution for the older GHC-specific --- "$topdir" variable. The "topdir" is the location of the ghc --- installation (obtained from the -B option). -mungePackagePaths top_dir pkgroot pkg = - pkg { - importDirs = munge_paths (importDirs pkg), - includeDirs = munge_paths (includeDirs pkg), - libraryDirs = munge_paths (libraryDirs pkg), - frameworkDirs = munge_paths (frameworkDirs pkg), - haddockInterfaces = munge_paths (haddockInterfaces pkg), - -- haddock-html is allowed to be either a URL or a file - haddockHTMLs = munge_paths (munge_urls (haddockHTMLs pkg)) - } - where - munge_paths = map munge_path - munge_urls = map munge_url - - munge_path p - | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p' - | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p' - | otherwise = p - - munge_url p - | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p' - | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p' - | otherwise = p - - toUrlPath r p = "file:///" - -- URLs always use posix style '/' separators: - ++ FilePath.Posix.joinPath - (r : -- We need to drop a leading "/" or "\\" - -- if there is one: - dropWhile (all isPathSeparator) - (FilePath.splitDirectories p)) - - -- We could drop the separator here, and then use above. However, - -- by leaving it in and using ++ we keep the same path separator - -- rather than letting FilePath change it to use \ as the separator - stripVarPrefix var path = case stripPrefix var path of - Just [] -> Just [] - Just cs@(c : _) | isPathSeparator c -> Just cs - _ -> Nothing - - --- ----------------------------------------------------------------------------- --- Creating a new package DB - -initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO () -initPackageDB filename verbosity _flags = do - let eexist = die ("cannot create: " ++ filename ++ " already exists") - b1 <- doesFileExist filename - when b1 eexist - b2 <- doesDirectoryExist filename - when b2 eexist - filename_abs <- absolutePath filename - changeDB verbosity [] PackageDB { - location = filename, locationAbsolute = filename_abs, - packages = [] - } - --- ----------------------------------------------------------------------------- --- Registering - -registerPackage :: FilePath - -> Verbosity - -> [Flag] - -> Bool -- auto_ghci_libs - -> Bool -- expand_env_vars - -> Bool -- update - -> Force - -> IO () -registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do - (db_stack, Just to_modify, _flag_dbs) <- - getPkgDatabases verbosity True True False{-expand vars-} my_flags - - let - db_to_operate_on = my_head "register" $ - filter ((== to_modify).location) db_stack - -- - when (auto_ghci_libs && verbosity >= Silent) $ - warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4" - -- - s <- - case input of - "-" -> do - when (verbosity >= Normal) $ - info "Reading package info from stdin ... " - -- fix the encoding to UTF-8, since this is an interchange format - hSetEncoding stdin utf8 - getContents - f -> do - when (verbosity >= Normal) $ - info ("Reading package info from " ++ show f ++ " ... ") - readUTF8File f - - expanded <- if expand_env_vars then expandEnvVars s force - else return s - - (pkg, ws) <- parsePackageInfo expanded - when (verbosity >= Normal) $ - infoLn "done." - - -- report any warnings from the parse phase - _ <- reportValidateErrors [] ws - (display (sourcePackageId pkg) ++ ": Warning: ") Nothing - - -- validate the expanded pkg, but register the unexpanded - pkgroot <- absolutePath (takeDirectory to_modify) - let top_dir = takeDirectory (location (last db_stack)) - pkg_expanded = mungePackagePaths top_dir pkgroot pkg - - let truncated_stack = dropWhile ((/= to_modify).location) db_stack - -- truncate the stack for validation, because we don't allow - -- packages lower in the stack to refer to those higher up. - validatePackageConfig pkg_expanded verbosity truncated_stack auto_ghci_libs update force - let - removes = [ RemovePackage p - | p <- packages db_to_operate_on, - sourcePackageId p == sourcePackageId pkg ] - -- - changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on - -parsePackageInfo - :: String - -> IO (InstalledPackageInfo, [ValidateWarning]) -parsePackageInfo str = - case parseInstalledPackageInfo str of - ParseOk warnings ok -> return (ok, ws) - where - ws = [ msg | PWarning msg <- warnings - , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ] - ParseFailed err -> case locatedErrorMsg err of - (Nothing, s) -> die s - (Just l, s) -> die (show l ++ ": " ++ s) - --- ----------------------------------------------------------------------------- --- Making changes to a package database - -data DBOp = RemovePackage InstalledPackageInfo - | AddPackage InstalledPackageInfo - | ModifyPackage InstalledPackageInfo - -changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO () -changeDB verbosity cmds db = do - let db' = updateInternalDB db cmds - isfile <- doesFileExist (location db) - if isfile - then writeNewConfig verbosity (location db') (packages db') - else do - createDirectoryIfMissing True (location db) - changeDBDir verbosity cmds db' - -updateInternalDB :: PackageDB -> [DBOp] -> PackageDB -updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds } - where - do_cmd pkgs (RemovePackage p) = - filter ((/= installedPackageId p) . installedPackageId) pkgs - do_cmd pkgs (AddPackage p) = p : pkgs - do_cmd pkgs (ModifyPackage p) = - do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p) - - -changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO () -changeDBDir verbosity cmds db = do - mapM_ do_cmd cmds - updateDBCache verbosity db - where - do_cmd (RemovePackage p) = do - let file = location db display (installedPackageId p) <.> "conf" - when (verbosity > Normal) $ infoLn ("removing " ++ file) - removeFileSafe file - do_cmd (AddPackage p) = do - let file = location db display (installedPackageId p) <.> "conf" - when (verbosity > Normal) $ infoLn ("writing " ++ file) - writeFileUtf8Atomic file (showInstalledPackageInfo p) - do_cmd (ModifyPackage p) = - do_cmd (AddPackage p) - -updateDBCache :: Verbosity -> PackageDB -> IO () -updateDBCache verbosity db = do - let filename = location db cachefilename - when (verbosity > Normal) $ - infoLn ("writing cache " ++ filename) - writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db)) - `catchIO` \e -> - if isPermissionError e - then die (filename ++ ": you don't have permission to modify this file") - else ioError e -#ifndef mingw32_HOST_OS - status <- getFileStatus filename - setFileTimes (location db) (accessTime status) (modificationTime status) -#endif - --- ----------------------------------------------------------------------------- --- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar - -exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () -exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True}) - -hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () -hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False}) - -trustPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () -trustPackage = modifyPackage (\p -> ModifyPackage p{trusted=True}) - -distrustPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () -distrustPackage = modifyPackage (\p -> ModifyPackage p{trusted=False}) - -unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () -unregisterPackage = modifyPackage RemovePackage - -modifyPackage - :: (InstalledPackageInfo -> DBOp) - -> PackageIdentifier - -> Verbosity - -> [Flag] - -> Force - -> IO () -modifyPackage fn pkgid verbosity my_flags force = do - (db_stack, Just _to_modify, _flag_dbs) <- - getPkgDatabases verbosity True{-modify-} True{-use cache-} False{-expand vars-} my_flags - - (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid) - let - db_name = location db - pkgs = packages db - - pids = map sourcePackageId ps - - cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ] - new_db = updateInternalDB db cmds - - old_broken = brokenPackages (allPackagesInStack db_stack) - rest_of_stack = filter ((/= db_name) . location) db_stack - new_stack = new_db : rest_of_stack - new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack)) - newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken - -- - when (not (null newly_broken)) $ - dieOrForceAll force ("unregistering " ++ display pkgid ++ - " would break the following packages: " - ++ unwords (map display newly_broken)) - - changeDB verbosity cmds db - -recache :: Verbosity -> [Flag] -> IO () -recache verbosity my_flags = do - (db_stack, Just to_modify, _flag_dbs) <- - getPkgDatabases verbosity True{-modify-} False{-no cache-} False{-expand vars-} my_flags - let - db_to_operate_on = my_head "recache" $ - filter ((== to_modify).location) db_stack - -- - changeDB verbosity [] db_to_operate_on - --- ----------------------------------------------------------------------------- --- Listing packages - -listPackages :: Verbosity -> [Flag] -> Maybe PackageArg - -> Maybe (String->Bool) - -> IO () -listPackages verbosity my_flags mPackageName mModuleName = do - let simple_output = FlagSimpleOutput `elem` my_flags - (db_stack, _, flag_db_stack) <- - getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags - - let db_stack_filtered -- if a package is given, filter out all other packages - | Just this <- mPackageName = - [ db{ packages = filter (this `matchesPkg`) (packages db) } - | db <- flag_db_stack ] - | Just match <- mModuleName = -- packages which expose mModuleName - [ db{ packages = filter (match `exposedInPkg`) (packages db) } - | db <- flag_db_stack ] - | otherwise = flag_db_stack - - db_stack_sorted - = [ db{ packages = sort_pkgs (packages db) } - | db <- db_stack_filtered ] - where sort_pkgs = sortBy cmpPkgIds - cmpPkgIds pkg1 pkg2 = - case pkgName p1 `compare` pkgName p2 of - LT -> LT - GT -> GT - EQ -> pkgVersion p1 `compare` pkgVersion p2 - where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2) - - stack = reverse db_stack_sorted - - match `exposedInPkg` pkg = any match (map display $ exposedModules pkg) - - pkg_map = allPackagesInStack db_stack - broken = map sourcePackageId (brokenPackages pkg_map) - - show_normal PackageDB{ location = db_name, packages = pkg_confs } = - do hPutStrLn stdout (db_name ++ ":") - if null pp_pkgs - then hPutStrLn stdout " (no packages)" - else hPutStrLn stdout $ unlines (map (" " ++) pp_pkgs) - where - -- Sort using instance Ord PackageId - pp_pkgs = map pp_pkg . sortBy (comparing installedPackageId) $ pkg_confs - pp_pkg p - | sourcePackageId p `elem` broken = printf "{%s}" doc - | exposed p = doc - | otherwise = printf "(%s)" doc - where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid - | otherwise = pkg - where - InstalledPackageId ipid = installedPackageId p - pkg = display (sourcePackageId p) - - show_simple = simplePackageList my_flags . allPackagesInStack - - when (not (null broken) && not simple_output && verbosity /= Silent) $ do - prog <- getProgramName - warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.") - - if simple_output then show_simple stack else do - -#if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING) - mapM_ show_normal stack -#else - let - show_colour withF db = - mconcat $ map (<#> termText "\n") $ - (termText (location db) : - map (termText " " <#>) (map pp_pkg (packages db))) - where - pp_pkg p - | sourcePackageId p `elem` broken = withF Red doc - | exposed p = doc - | otherwise = withF Blue doc - where doc | verbosity >= Verbose - = termText (printf "%s (%s)" pkg ipid) - | otherwise - = termText pkg - where - InstalledPackageId ipid = installedPackageId p - pkg = display (sourcePackageId p) - - is_tty <- hIsTerminalDevice stdout - if not is_tty - then mapM_ show_normal stack - else do tty <- Terminfo.setupTermFromEnv - case Terminfo.getCapability tty withForegroundColor of - Nothing -> mapM_ show_normal stack - Just w -> runTermOutput tty $ mconcat $ - map (show_colour w) stack -#endif - -simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO () -simplePackageList my_flags pkgs = do - let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName - else display - -- Sort using instance Ord PackageId - strs = map showPkg $ sort $ map sourcePackageId pkgs - when (not (null pkgs)) $ - hPutStrLn stdout $ concat $ intersperse " " strs - -showPackageDot :: Verbosity -> [Flag] -> IO () -showPackageDot verbosity myflags = do - (_, _, flag_db_stack) <- - getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} myflags - - let all_pkgs = allPackagesInStack flag_db_stack - ipix = PackageIndex.fromList all_pkgs - - putStrLn "digraph {" - let quote s = '"':s ++ "\"" - mapM_ putStrLn [ quote from ++ " -> " ++ quote to - | p <- all_pkgs, - let from = display (sourcePackageId p), - depid <- depends p, - Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid], - let to = display (sourcePackageId dep) - ] - putStrLn "}" - --- ----------------------------------------------------------------------------- --- Prints the highest (hidden or exposed) version of a package - -latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO () -latestPackage verbosity my_flags pkgid = do - (_, _, flag_db_stack) <- - getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags - - ps <- findPackages flag_db_stack (Id pkgid) - case ps of - [] -> die "no matches" - _ -> show_pkg . maximum . map sourcePackageId $ ps - where - show_pkg pid = hPutStrLn stdout (display pid) - --- ----------------------------------------------------------------------------- --- Describe - -describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO () -describePackage verbosity my_flags pkgarg expand_pkgroot = do - (_, _, flag_db_stack) <- - getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags - dbs <- findPackagesByDB flag_db_stack pkgarg - doDump expand_pkgroot [ (pkg, locationAbsolute db) - | (db, pkgs) <- dbs, pkg <- pkgs ] - -dumpPackages :: Verbosity -> [Flag] -> Bool -> IO () -dumpPackages verbosity my_flags expand_pkgroot = do - (_, _, flag_db_stack) <- - getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags - doDump expand_pkgroot [ (pkg, locationAbsolute db) - | db <- flag_db_stack, pkg <- packages db ] - -doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO () -doDump expand_pkgroot pkgs = do - -- fix the encoding to UTF-8, since this is an interchange format - hSetEncoding stdout utf8 - putStrLn $ - intercalate "---\n" - [ if expand_pkgroot - then showInstalledPackageInfo pkg - else showInstalledPackageInfo pkg ++ pkgrootField - | (pkg, pkgloc) <- pkgs - , let pkgroot = takeDirectory pkgloc - pkgrootField = "pkgroot: " ++ show pkgroot ++ "\n" ] - --- PackageId is can have globVersion for the version -findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo] -findPackages db_stack pkgarg - = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg - -findPackagesByDB :: PackageDBStack -> PackageArg - -> IO [(PackageDB, [InstalledPackageInfo])] -findPackagesByDB db_stack pkgarg - = case [ (db, matched) - | db <- db_stack, - let matched = filter (pkgarg `matchesPkg`) (packages db), - not (null matched) ] of - [] -> die ("cannot find package " ++ pkg_msg pkgarg) - ps -> return ps - where - pkg_msg (Id pkgid) = display pkgid - pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat - -matches :: PackageIdentifier -> PackageIdentifier -> Bool -pid `matches` pid' - = (pkgName pid == pkgName pid') - && (pkgVersion pid == pkgVersion pid' || not (realVersion pid)) - -realVersion :: PackageIdentifier -> Bool -realVersion pkgid = versionBranch (pkgVersion pkgid) /= [] - -- when versionBranch == [], this is a glob - -matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool -(Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg -(Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg)) - --- ----------------------------------------------------------------------------- --- Field - -describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO () -describeField verbosity my_flags pkgarg fields expand_pkgroot = do - (_, _, flag_db_stack) <- - getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags - fns <- mapM toField fields - ps <- findPackages flag_db_stack pkgarg - mapM_ (selectFields fns) ps - where showFun = if FlagSimpleOutput `elem` my_flags - then showSimpleInstalledPackageInfoField - else showInstalledPackageInfoField - toField f = case showFun f of - Nothing -> die ("unknown field: " ++ f) - Just fn -> return fn - selectFields fns pinfo = mapM_ (\fn->putStrLn (fn pinfo)) fns - - --- ----------------------------------------------------------------------------- --- Check: Check consistency of installed packages - -checkConsistency :: Verbosity -> [Flag] -> IO () -checkConsistency verbosity my_flags = do - (db_stack, _, _) <- - getPkgDatabases verbosity True True{-use cache-} True{-expand vars-} my_flags - -- check behaves like modify for the purposes of deciding which - -- databases to use, because ordering is important. - - let simple_output = FlagSimpleOutput `elem` my_flags - - let pkgs = allPackagesInStack db_stack - - checkPackage p = do - (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack False True - if null es - then do when (not simple_output) $ do - _ <- reportValidateErrors [] ws "" Nothing - return () - return [] - else do - when (not simple_output) $ do - reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":") - _ <- reportValidateErrors es ws " " Nothing - return () - return [p] - - broken_pkgs <- concat `fmap` mapM checkPackage pkgs - - let filterOut pkgs1 pkgs2 = filter not_in pkgs2 - where not_in p = sourcePackageId p `notElem` all_ps - all_ps = map sourcePackageId pkgs1 - - let not_broken_pkgs = filterOut broken_pkgs pkgs - (_, trans_broken_pkgs) = closure [] not_broken_pkgs - all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs - - when (not (null all_broken_pkgs)) $ do - if simple_output - then simplePackageList my_flags all_broken_pkgs - else do - reportError ("\nThe following packages are broken, either because they have a problem\n"++ - "listed above, or because they depend on a broken package.") - mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs - - when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1) - - -closure :: [InstalledPackageInfo] -> [InstalledPackageInfo] - -> ([InstalledPackageInfo], [InstalledPackageInfo]) -closure pkgs db_stack = go pkgs db_stack - where - go avail not_avail = - case partition (depsAvailable avail) not_avail of - ([], not_avail') -> (avail, not_avail') - (new_avail, not_avail') -> go (new_avail ++ avail) not_avail' - - depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo - -> Bool - depsAvailable pkgs_ok pkg = null dangling - where dangling = filter (`notElem` pids) (depends pkg) - pids = map installedPackageId pkgs_ok - - -- we want mutually recursive groups of package to show up - -- as broken. (#1750) - -brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo] -brokenPackages pkgs = snd (closure [] pkgs) - --- ----------------------------------------------------------------------------- --- Manipulating package.conf files - -type InstalledPackageInfoString = InstalledPackageInfo_ String - -convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString -convertPackageInfoOut - (pkgconf@(InstalledPackageInfo { exposedModules = e, - hiddenModules = h })) = - pkgconf{ exposedModules = map display e, - hiddenModules = map display h } - -convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo -convertPackageInfoIn - (pkgconf@(InstalledPackageInfo { exposedModules = e, - hiddenModules = h })) = - pkgconf{ exposedModules = map convert e, - hiddenModules = map convert h } - where convert = fromJust . simpleParse - -writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO () -writeNewConfig verbosity filename ipis = do - when (verbosity >= Normal) $ - info "Writing new package config file... " - createDirectoryIfMissing True $ takeDirectory filename - let shown = concat $ intersperse ",\n " - $ map (show . convertPackageInfoOut) ipis - fileContents = "[" ++ shown ++ "\n]" - writeFileUtf8Atomic filename fileContents - `catchIO` \e -> - if isPermissionError e - then die (filename ++ ": you don't have permission to modify this file") - else ioError e - when (verbosity >= Normal) $ - infoLn "done." - ------------------------------------------------------------------------------ --- Sanity-check a new package config, and automatically build GHCi libs --- if requested. - -type ValidateError = (Force,String) -type ValidateWarning = String - -newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) } - -instance Functor Validate where - fmap = liftM - -instance Applicative Validate where - pure = return - (<*>) = ap - -instance Monad Validate where - return a = V $ return (a, [], []) - m >>= k = V $ do - (a, es, ws) <- runValidate m - (b, es', ws') <- runValidate (k a) - return (b,es++es',ws++ws') - -verror :: Force -> String -> Validate () -verror f s = V (return ((),[(f,s)],[])) - -vwarn :: String -> Validate () -vwarn s = V (return ((),[],["Warning: " ++ s])) - -liftIO :: IO a -> Validate a -liftIO k = V (k >>= \a -> return (a,[],[])) - --- returns False if we should die -reportValidateErrors :: [ValidateError] -> [ValidateWarning] - -> String -> Maybe Force -> IO Bool -reportValidateErrors es ws prefix mb_force = do - mapM_ (warn . (prefix++)) ws - oks <- mapM report es - return (and oks) - where - report (f,s) - | Just force <- mb_force - = if (force >= f) - then do reportError (prefix ++ s ++ " (ignoring)") - return True - else if f < CannotForce - then do reportError (prefix ++ s ++ " (use --force to override)") - return False - else do reportError err - return False - | otherwise = do reportError err - return False - where - err = prefix ++ s - -validatePackageConfig :: InstalledPackageInfo - -> Verbosity - -> PackageDBStack - -> Bool -- auto-ghc-libs - -> Bool -- update, or check - -> Force - -> IO () -validatePackageConfig pkg verbosity db_stack auto_ghci_libs update force = do - (_,es,ws) <- runValidate $ checkPackageConfig pkg verbosity db_stack auto_ghci_libs update - ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force) - when (not ok) $ exitWith (ExitFailure 1) - -checkPackageConfig :: InstalledPackageInfo - -> Verbosity - -> PackageDBStack - -> Bool -- auto-ghc-libs - -> Bool -- update, or check - -> Validate () -checkPackageConfig pkg verbosity db_stack auto_ghci_libs update = do - checkInstalledPackageId pkg db_stack update - checkPackageId pkg - checkDuplicates db_stack pkg update - mapM_ (checkDep db_stack) (depends pkg) - checkDuplicateDepends (depends pkg) - mapM_ (checkDir False "import-dirs") (importDirs pkg) - mapM_ (checkDir True "library-dirs") (libraryDirs pkg) - mapM_ (checkDir True "include-dirs") (includeDirs pkg) - mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg) - mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg) - mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg) - checkModules pkg - mapM_ (checkHSLib verbosity (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg) - -- ToDo: check these somehow? - -- extra_libraries :: [String], - -- c_includes :: [String], - -checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool - -> Validate () -checkInstalledPackageId ipi db_stack update = do - let ipid@(InstalledPackageId str) = installedPackageId ipi - when (null str) $ verror CannotForce "missing id field" - let dups = [ p | p <- allPackagesInStack db_stack, - installedPackageId p == ipid ] - when (not update && not (null dups)) $ - verror CannotForce $ - "package(s) with this id already exist: " ++ - unwords (map (display.packageId) dups) - --- When the package name and version are put together, sometimes we can --- end up with a package id that cannot be parsed. This will lead to --- difficulties when the user wants to refer to the package later, so --- we check that the package id can be parsed properly here. -checkPackageId :: InstalledPackageInfo -> Validate () -checkPackageId ipi = - let str = display (sourcePackageId ipi) in - case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of - [_] -> return () - [] -> verror CannotForce ("invalid package identifier: " ++ str) - _ -> verror CannotForce ("ambiguous package identifier: " ++ str) - -checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate () -checkDuplicates db_stack pkg update = do - let - pkgid = sourcePackageId pkg - pkgs = packages (head db_stack) - -- - -- Check whether this package id already exists in this DB - -- - when (not update && (pkgid `elem` map sourcePackageId pkgs)) $ - verror CannotForce $ - "package " ++ display pkgid ++ " is already installed" - - let - uncasep = map toLower . display - dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs) - - when (not update && not (null dups)) $ verror ForceAll $ - "Package names may be treated case-insensitively in the future.\n"++ - "Package " ++ display pkgid ++ - " overlaps with: " ++ unwords (map display dups) - -checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate () -checkDir = checkPath False True -checkFile = checkPath False False -checkDirURL = checkPath True True - -checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate () -checkPath url_ok is_dir warn_only thisfield d - | url_ok && ("http://" `isPrefixOf` d - || "https://" `isPrefixOf` d) = return () - - | url_ok - , Just d' <- stripPrefix "file://" d - = checkPath False is_dir warn_only thisfield d' - - -- Note: we don't check for $topdir/${pkgroot} here. We rely on these - -- variables having been expanded already, see mungePackagePaths. - - | isRelative d = verror ForceFiles $ - thisfield ++ ": " ++ d ++ " is a relative path which " - ++ "makes no sense (as there is nothing for it to be " - ++ "relative to). You can make paths relative to the " - ++ "package database itself by using ${pkgroot}." - -- relative paths don't make any sense; #4134 - | otherwise = do - there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d - when (not there) $ - let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a " - ++ if is_dir then "directory" else "file" - in - if warn_only - then vwarn msg - else verror ForceFiles msg - -checkDep :: PackageDBStack -> InstalledPackageId -> Validate () -checkDep db_stack pkgid - | pkgid `elem` pkgids = return () - | otherwise = verror ForceAll ("dependency \"" ++ display pkgid - ++ "\" doesn't exist") - where - all_pkgs = allPackagesInStack db_stack - pkgids = map installedPackageId all_pkgs - -checkDuplicateDepends :: [InstalledPackageId] -> Validate () -checkDuplicateDepends deps - | null dups = return () - | otherwise = verror ForceAll ("package has duplicate dependencies: " ++ - unwords (map display dups)) - where - dups = [ p | (p:_:_) <- group (sort deps) ] - -checkHSLib :: Verbosity -> [String] -> Bool -> String -> Validate () -checkHSLib verbosity dirs auto_ghci_libs lib = do - let batch_lib_file = "lib" ++ lib ++ ".a" - filenames = ["lib" ++ lib ++ ".a", - "lib" ++ lib ++ ".p_a", - "lib" ++ lib ++ "-ghc" ++ showVersion ghcVersion ++ ".so", - "lib" ++ lib ++ "-ghc" ++ showVersion ghcVersion ++ ".dylib", - lib ++ "-ghc" ++ showVersion ghcVersion ++ ".dll"] - m <- liftIO $ doesFileExistOnPath filenames dirs - case m of - Nothing -> verror ForceFiles ("cannot find any of " ++ show filenames ++ - " on library path") - Just dir -> liftIO $ checkGHCiLib verbosity dir batch_lib_file lib auto_ghci_libs - -doesFileExistOnPath :: [FilePath] -> [FilePath] -> IO (Maybe FilePath) -doesFileExistOnPath filenames paths = go fullFilenames - where fullFilenames = [ (path, path filename) - | filename <- filenames - , path <- paths ] - go [] = return Nothing - go ((p, fp) : xs) = do b <- doesFileExist fp - if b then return (Just p) else go xs - -checkModules :: InstalledPackageInfo -> Validate () -checkModules pkg = do - mapM_ findModule (exposedModules pkg ++ hiddenModules pkg) - where - findModule modl = - -- there's no interface file for GHC.Prim - unless (modl == fromString "GHC.Prim") $ do - let files = [ toFilePath modl <.> extension - | extension <- ["hi", "p_hi", "dyn_hi" ] ] - m <- liftIO $ doesFileExistOnPath files (importDirs pkg) - when (isNothing m) $ - verror ForceFiles ("cannot find any of " ++ show files) - -checkGHCiLib :: Verbosity -> String -> String -> String -> Bool -> IO () -checkGHCiLib verbosity batch_lib_dir batch_lib_file lib auto_build - | auto_build = autoBuildGHCiLib verbosity batch_lib_dir batch_lib_file ghci_lib_file - | otherwise = return () - where - ghci_lib_file = lib <.> "o" - --- automatically build the GHCi version of a batch lib, --- using ld --whole-archive. - -autoBuildGHCiLib :: Verbosity -> String -> String -> String -> IO () -autoBuildGHCiLib verbosity dir batch_file ghci_file = do - let ghci_lib_file = dir ++ '/':ghci_file - batch_lib_file = dir ++ '/':batch_file - when (verbosity >= Normal) $ - info ("building GHCi library " ++ ghci_lib_file ++ "...") -#if defined(darwin_HOST_OS) - r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file] -#elif defined(mingw32_HOST_OS) - execDir <- getLibDir - r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file] -#else - r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file] -#endif - when (r /= ExitSuccess) $ exitWith r - when (verbosity >= Normal) $ - infoLn (" done.") - --- ----------------------------------------------------------------------------- --- Searching for modules - -#if not_yet - -findModules :: [FilePath] -> IO [String] -findModules paths = - mms <- mapM searchDir paths - return (concat mms) - -searchDir path prefix = do - fs <- getDirectoryEntries path `catchIO` \_ -> return [] - searchEntries path prefix fs - -searchEntries path prefix [] = return [] -searchEntries path prefix (f:fs) - | looks_like_a_module = do - ms <- searchEntries path prefix fs - return (prefix `joinModule` f : ms) - | looks_like_a_component = do - ms <- searchDir (path f) (prefix `joinModule` f) - ms' <- searchEntries path prefix fs - return (ms ++ ms') - | otherwise - searchEntries path prefix fs - - where - (base,suffix) = splitFileExt f - looks_like_a_module = - suffix `elem` haskell_suffixes && - all okInModuleName base - looks_like_a_component = - null suffix && all okInModuleName base - -okInModuleName c - -#endif - --- --------------------------------------------------------------------------- --- expanding environment variables in the package configuration - -expandEnvVars :: String -> Force -> IO String -expandEnvVars str0 force = go str0 "" - where - go "" acc = return $! reverse acc - go ('$':'{':str) acc | (var, '}':rest) <- break close str - = do value <- lookupEnvVar var - go rest (reverse value ++ acc) - where close c = c == '}' || c == '\n' -- don't span newlines - go (c:str) acc - = go str (c:acc) - - lookupEnvVar :: String -> IO String - lookupEnvVar "pkgroot" = return "${pkgroot}" -- these two are special, - lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them - lookupEnvVar nm = - catchIO (System.Environment.getEnv nm) - (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++ - show nm) - return "") - ------------------------------------------------------------------------------ - -getProgramName :: IO String -getProgramName = liftM (`withoutSuffix` ".bin") getProgName - where str `withoutSuffix` suff - | suff `isSuffixOf` str = take (length str - length suff) str - | otherwise = str - -bye :: String -> IO a -bye s = putStr s >> exitWith ExitSuccess - -die :: String -> IO a -die = dieWith 1 - -dieWith :: Int -> String -> IO a -dieWith ec s = do - prog <- getProgramName - reportError (prog ++ ": " ++ s) - exitWith (ExitFailure ec) - -dieOrForceAll :: Force -> String -> IO () -dieOrForceAll ForceAll s = ignoreError s -dieOrForceAll _other s = dieForcible s - -warn :: String -> IO () -warn = reportError - --- send info messages to stdout -infoLn :: String -> IO () -infoLn = putStrLn - -info :: String -> IO () -info = putStr - -ignoreError :: String -> IO () -ignoreError s = reportError (s ++ " (ignoring)") - -reportError :: String -> IO () -reportError s = do hFlush stdout; hPutStrLn stderr s - -dieForcible :: String -> IO () -dieForcible s = die (s ++ " (use --force to override)") - -my_head :: String -> [a] -> a -my_head s [] = error s -my_head _ (x : _) = x - -getLibDir :: IO (Maybe String) -getLibDir = return $ Just hasteSysDir - ------------------------------------------ --- Adapted from ghc/compiler/utils/Panic - -installSignalHandlers :: IO () -installSignalHandlers = do - threadid <- myThreadId - let - interrupt = Exception.throwTo threadid - (Exception.ErrorCall "interrupted") - -- -#if !defined(mingw32_HOST_OS) - _ <- installHandler sigQUIT (Catch interrupt) Nothing - _ <- installHandler sigINT (Catch interrupt) Nothing - return () -#else - -- GHC 6.3+ has support for console events on Windows - -- NOTE: running GHCi under a bash shell for some reason requires - -- you to press Ctrl-Break rather than Ctrl-C to provoke - -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know - -- why --SDM 17/12/2004 - let sig_handler ControlC = interrupt - sig_handler Break = interrupt - sig_handler _ = return () - - _ <- installHandler (Catch sig_handler) - return () -#endif - -#if mingw32_HOST_OS || mingw32_TARGET_OS -throwIOIO :: Exception.IOException -> IO a -throwIOIO = Exception.throwIO -#endif - -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -catchIO = Exception.catch - -catchError :: IO a -> (String -> IO a) -> IO a -catchError io handler = io `Exception.catch` handler' - where handler' (Exception.ErrorCall err) = handler err - -tryIO :: IO a -> IO (Either Exception.IOException a) -tryIO = Exception.try - -writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO () -writeBinaryFileAtomic targetFile obj = - withFileAtomic targetFile $ \h -> do - hSetBinaryMode h True - B.hPutStr h (Bin.encode obj) - -writeFileUtf8Atomic :: FilePath -> String -> IO () -writeFileUtf8Atomic targetFile content = - withFileAtomic targetFile $ \h -> do - hSetEncoding h utf8 - hPutStr h content - --- copied from Cabal's Distribution.Simple.Utils, except that we want --- to use text files here, rather than binary files. -withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO () -withFileAtomic targetFile write_content = do - (newFile, newHandle) <- openNewFile targetDir template - do write_content newHandle - hClose newHandle -#if mingw32_HOST_OS || mingw32_TARGET_OS - renameFile newFile targetFile - -- If the targetFile exists then renameFile will fail - `catchIO` \err -> do - exists <- doesFileExist targetFile - if exists - then do removeFileSafe targetFile - -- Big fat hairy race condition - renameFile newFile targetFile - -- If the removeFile succeeds and the renameFile fails - -- then we've lost the atomic property. - else throwIOIO err -#else - renameFile newFile targetFile -#endif - `Exception.onException` do hClose newHandle - removeFileSafe newFile - where - template = targetName <.> "tmp" - targetDir | null targetDir_ = "." - | otherwise = targetDir_ - --TODO: remove this when takeDirectory/splitFileName is fixed - -- to always return a valid dir - (targetDir_,targetName) = splitFileName targetFile - -openNewFile :: FilePath -> String -> IO (FilePath, Handle) -openNewFile dir template = do - -- this was added to System.IO in 6.12.1 - -- we must use this version because the version below opens the file - -- in binary mode. - openTempFileWithDefaultPermissions dir template - --- | The function splits the given string to substrings --- using 'isSearchPathSeparator'. -parseSearchPath :: String -> [FilePath] -parseSearchPath path = split path - where - split :: String -> [String] - split s = - case rest' of - [] -> [chunk] - _:rest -> chunk : split rest - where - chunk = - case chunk' of -#ifdef mingw32_HOST_OS - ('\"':xs@(_:_)) | last xs == '\"' -> init xs -#endif - _ -> chunk' - - (chunk', rest') = break isSearchPathSeparator s - -readUTF8File :: FilePath -> IO String -readUTF8File file = do - h <- openFile file ReadMode - -- fix the encoding to UTF-8 - hSetEncoding h utf8 - hGetContents h - --- removeFileSave doesn't throw an exceptions, if the file is already deleted -removeFileSafe :: FilePath -> IO () -removeFileSafe fn = - removeFile fn `catchIO` \ e -> - when (not $ isDoesNotExistError e) $ ioError e - -absolutePath :: FilePath -> IO FilePath -absolutePath path = return . normalise . ( path) =<< getCurrentDirectory - --- | Only global packages may be marked as relocatable! --- May break horribly for general use, only reliable for Haste base packages. -relocate :: [String] -> String -> Sh.Shell () -relocate packages pkg = do - pi <- Sh.run hastePkgBinary (packages ++ ["describe", pkg]) "" - Sh.run_ hastePkgBinary (packages ++ ["update", "-", "--force", "--global"]) - (reloc pi) - where - reloc = unlines . map fixPath . lines - - fixPath s - | isKey "library-dirs: " s = prefix s "library-dirs" importDir - | isKey "import-dirs: " s = prefix s "import-dirs" importDir - | isKey "haddock-interfaces: " s = prefix s "haddock-interfaces" importDir - | isKey "haddock-html: " s = prefix s "haddock-html" importDir - | isKey "include-dirs: " s = "include-dirs: " ++ includeDir - | otherwise = s - - prefix s pfx path = pfx ++ ": " ++ path stripPrefix s - - stripPrefix s - | os == "darwin" = - case take 3 $ reverse $ splitPath s of - [third, second, first] -> first second third - | otherwise = - case take 2 $ reverse $ splitPath s of - [second, first] -> first second - - isKey _ "" = - False - isKey key str = - and $ zipWith (==) key str - - importDir - | os == "linux" = "${pkgroot}" "libraries" "lib" - | otherwise = "${pkgroot}" "libraries" - includeDir = "${pkgroot}" "include" +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ < 709 +import qualified HastePkg708 as Real +#else +import qualified HastePkg710 as Real +#endif + +main :: IO () +main = Real.main