haste-compiler 0.5.0.1 → 0.5.1.0

raw patch · 50 files changed

+6989/−3233 lines, 50 filesdep ~basedep ~directorydep ~ghcsetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, directory, ghc, ghc-simple, shellmate

API changes (from Hackage documentation)

- Haste.Foreign: JSAny :: (Ptr Any) -> JSAny

- Haste.Foreign: class Generic a

- Haste.Foreign: instance [overlap ok] (FromAny a, JSFunc b) => JSFunc (a -> b)

- Haste.Foreign: instance [overlap ok] (FromAny a, JSFunc b) => ToAny (a -> b)

- Haste.Foreign: instance [overlap ok] (ToAny a, FFI b) => FFI (a -> b)

- Haste.Foreign: instance [overlap ok] (ToAny a, JS a ~ JSAny) => JSFunc a

- Haste.Foreign: instance [overlap ok] FFI a => FromAny a

- Haste.Foreign: instance [overlap ok] FromAny a => FFI (IO a)

- Haste.Foreign: instance [overlap ok] ToAny a => JSFunc (IO a)

- Haste.Foreign: instance [overlap ok] ToAny a => ToAny (IO a)

- Haste.Foreign: newtype JSAny

+ Haste.App: defaultConfig :: AppCfg

+ Haste.DOM: AttrName :: !JSString -> AttrName

+ Haste.DOM: PropName :: !JSString -> AttrName

+ Haste.DOM: StyleName :: !JSString -> AttrName

+ Haste.DOM: addChild :: (IsElem parent, IsElem child, MonadIO m) => child -> parent -> m ()

+ Haste.DOM: addChildBefore :: (IsElem parent, IsElem child, MonadIO m) => child -> parent -> child -> m ()

+ Haste.DOM: appendChild :: (IsElem parent, IsElem child, MonadIO m) => parent -> child -> m ()

+ Haste.DOM: attribute :: AttrName -> JSString -> Attribute

+ Haste.DOM: blur :: (IsElem e, MonadIO m) => e -> m ()

+ Haste.DOM: children :: [Elem] -> Attribute

+ Haste.DOM: clearChildren :: (IsElem e, MonadIO m) => e -> m ()

+ Haste.DOM: click :: (IsElem e, MonadIO m) => e -> m ()

+ Haste.DOM: data Attribute

+ Haste.DOM: deleteChild :: (IsElem parent, IsElem child, MonadIO m) => parent -> child -> m ()

+ Haste.DOM: document :: Elem

+ Haste.DOM: documentBody :: Elem

+ Haste.DOM: focus :: (IsElem e, MonadIO m) => e -> m ()

+ Haste.DOM: getChildren :: (IsElem e, MonadIO m) => e -> m [Elem]

+ Haste.DOM: getFirstChild :: (IsElem e, MonadIO m) => e -> m (Maybe Elem)

+ Haste.DOM: getLastChild :: (IsElem e, MonadIO m) => e -> m (Maybe Elem)

+ Haste.DOM: insertChildBefore :: (IsElem parent, IsElem before, IsElem child, MonadIO m) => parent -> before -> child -> m ()

+ Haste.DOM: removeChild :: (IsElem parent, IsElem child, MonadIO m) => child -> parent -> m ()

+ Haste.DOM: set :: (IsElem e, MonadIO m) => e -> [Attribute] -> m ()

+ Haste.DOM: setChildren :: (IsElem parent, IsElem child, MonadIO m) => parent -> [child] -> m ()

+ Haste.DOM: with :: (IsElem e, MonadIO m) => m e -> [Attribute] -> m e

+ Haste.DOM.JSString: AttrName :: !JSString -> AttrName

+ Haste.DOM.JSString: PropName :: !JSString -> AttrName

+ Haste.DOM.JSString: StyleName :: !JSString -> AttrName

+ Haste.DOM.JSString: addChild :: (IsElem parent, IsElem child, MonadIO m) => child -> parent -> m ()

+ Haste.DOM.JSString: addChildBefore :: (IsElem parent, IsElem child, MonadIO m) => child -> parent -> child -> m ()

+ Haste.DOM.JSString: appendChild :: (IsElem parent, IsElem child, MonadIO m) => parent -> child -> m ()

+ Haste.DOM.JSString: attribute :: AttrName -> JSString -> Attribute

+ Haste.DOM.JSString: blur :: (IsElem e, MonadIO m) => e -> m ()

+ Haste.DOM.JSString: children :: [Elem] -> Attribute

+ Haste.DOM.JSString: clearChildren :: (IsElem e, MonadIO m) => e -> m ()

+ Haste.DOM.JSString: click :: (IsElem e, MonadIO m) => e -> m ()

+ Haste.DOM.JSString: data Attribute

+ Haste.DOM.JSString: deleteChild :: (IsElem parent, IsElem child, MonadIO m) => parent -> child -> m ()

+ Haste.DOM.JSString: document :: Elem

+ Haste.DOM.JSString: documentBody :: Elem

+ Haste.DOM.JSString: focus :: (IsElem e, MonadIO m) => e -> m ()

+ Haste.DOM.JSString: getChildren :: (IsElem e, MonadIO m) => e -> m [Elem]

+ Haste.DOM.JSString: getFirstChild :: (IsElem e, MonadIO m) => e -> m (Maybe Elem)

+ Haste.DOM.JSString: getLastChild :: (IsElem e, MonadIO m) => e -> m (Maybe Elem)

+ Haste.DOM.JSString: insertChildBefore :: (IsElem parent, IsElem before, IsElem child, MonadIO m) => parent -> before -> child -> m ()

+ Haste.DOM.JSString: removeChild :: (IsElem parent, IsElem child, MonadIO m) => child -> parent -> m ()

+ Haste.DOM.JSString: set :: (IsElem e, MonadIO m) => e -> [Attribute] -> m ()

+ Haste.DOM.JSString: setChildren :: (IsElem parent, IsElem child, MonadIO m) => parent -> [child] -> m ()

+ Haste.DOM.JSString: with :: (IsElem e, MonadIO m) => m e -> [Attribute] -> m e

+ Haste.Foreign: data JSAny

- Haste.Foreign: class FromAny a where listFromAny = mapM fromAny . fromPtr . __arr2lst 0

+ Haste.Foreign: class FromAny a where fromAny x = to <$> gFromAny False x listFromAny = mapM fromAny . fromPtr . __arr2lst 0

Files

Setup.hs +11/−28
haste-compiler.cabal +22/−28
include/primop-info-710.hs +1062/−0
include/primop-stricts-710.hs +16/−0
lib/Foreign.js +0/−2
lib/array.js +3/−3
lib/floatdecode.js +8/−0
lib/md5.js +34/−16
lib/rts.js +8/−4
libraries/haste-lib/src/Haste.hs +2/−2
libraries/haste-lib/src/Haste/Ajax.hs +1/−1
libraries/haste-lib/src/Haste/Any.hs +0/−350
libraries/haste-lib/src/Haste/App.hs +3/−3
libraries/haste-lib/src/Haste/Audio.hs +1/−1
libraries/haste-lib/src/Haste/Concurrent/Ajax.hs +1/−1
libraries/haste-lib/src/Haste/DOM.hs +8/−5
libraries/haste-lib/src/Haste/DOM/JSString.hs +9/−6
libraries/haste-lib/src/Haste/Events/KeyEvents.hs +1/−1
libraries/haste-lib/src/Haste/Foreign.hs +12/−155
libraries/haste-lib/src/Haste/JSON.hs +0/−1
libraries/haste-lib/src/Haste/JSType.hs +0/−293
libraries/haste-lib/src/Haste/Prim.hs +0/−122
libraries/haste-lib/src/Haste/Random.hs +1/−5
libraries/haste-prim/src/Haste/Prim.hs +123/−0
libraries/haste-prim/src/Haste/Prim/Any.hs +468/−0
libraries/haste-prim/src/Haste/Prim/Foreign.hs +174/−0
libraries/haste-prim/src/Haste/Prim/JSType.hs +293/−0
src/Data/JSTarget/AST.hs +2/−2
src/Data/JSTarget/Binary.hs +23/−21
src/Data/JSTarget/Op.hs +44/−38
src/Data/JSTarget/Optimize.hs +3/−1
src/Data/JSTarget/PP.hs +48/−14
src/Data/JSTarget/Print.hs +14/−8
src/Haste/CodeGen.hs +14/−9
src/Haste/Config.hs +49/−24
src/Haste/Environment.hs +40/−32
src/Haste/JSLib.hs +113/−0
src/Haste/Linker.hs +6/−2
src/Haste/Module.hs +75/−10
src/Haste/Opts.hs +46/−28
src/Haste/PrimOps.hs +7/−0
src/Haste/Version.hs +3/−3
src/haste-boot.hs +172/−73
src/haste-cabal.hs +0/−59
src/haste-cat.hs +16/−9
src/haste-copy-pkg.hs +1/−1
src/hastec.hs +113/−41
utils/haste-pkg/HastePkg708.hs +1834/−0
utils/haste-pkg/HastePkg710.hs +2095/−0
utils/haste-pkg/haste-pkg.hs +10/−1831

Setup.hs view

@@ -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

haste-compiler.cabal view

@@ -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

+ include/primop-info-710.hs view

@@ -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

+ include/primop-stricts-710.hs view

@@ -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

lib/Foreign.js view

@@ -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) {

lib/array.js view

@@ -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; }

lib/floatdecode.js view

@@ -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;

lib/md5.js view

@@ -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<s.length; i++)-        tail[i>>2] |= s.charCodeAt(i) << ((i%4) << 3);+    for (i=0; i<n; i++)+        tail[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]; }

lib/rts.js view

@@ -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) {

libraries/haste-lib/src/Haste.hs view

@@ -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

libraries/haste-lib/src/Haste/Ajax.hs view

@@ -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__

− libraries/haste-lib/src/Haste/Any.hs

@@ -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 ())

libraries/haste-lib/src/Haste/App.hs view

@@ -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

libraries/haste-lib/src/Haste/Audio.hs view

@@ -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

libraries/haste-lib/src/Haste/Concurrent/Ajax.hs view

@@ -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,

libraries/haste-lib/src/Haste/DOM.hs view

@@ -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

libraries/haste-lib/src/Haste/DOM/JSString.hs view

@@ -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

libraries/haste-lib/src/Haste/Events/KeyEvents.hs view

@@ -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

libraries/haste-lib/src/Haste/Foreign.hs view

@@ -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

libraries/haste-lib/src/Haste/JSON.hs view

@@ -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

− libraries/haste-lib/src/Haste/JSType.hs

@@ -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

− libraries/haste-lib/src/Haste/Prim.hs

@@ -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

libraries/haste-lib/src/Haste/Random.hs view

@@ -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

+ libraries/haste-prim/src/Haste/Prim.hs view

@@ -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

+ libraries/haste-prim/src/Haste/Prim/Any.hs view

@@ -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 ()

+ libraries/haste-prim/src/Haste/Prim/Foreign.hs view

@@ -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 []

+ libraries/haste-prim/src/Haste/Prim/JSType.hs view

@@ -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

src/Data/JSTarget/AST.hs view

@@ -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

src/Data/JSTarget/Binary.hs view

@@ -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]

src/Data/JSTarget/Op.hs view

@@ -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

src/Data/JSTarget/Optimize.hs view

@@ -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

src/Data/JSTarget/PP.hs view

@@ -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

src/Data/JSTarget/Print.hs view

@@ -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

src/Haste/CodeGen.hs view

@@ -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)

src/Haste/Config.hs view

@@ -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

src/Haste/Environment.hs view

@@ -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

+ src/Haste/JSLib.hs view

@@ -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

src/Haste/Linker.hs view

@@ -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

src/Haste/Module.hs view

@@ -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

src/Haste/Opts.hs view

@@ -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

src/Haste/PrimOps.hs view

@@ -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) []

src/Haste/Version.hs view

@@ -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

src/haste-boot.hs view

@@ -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] ""

− src/haste-cabal.hs

@@ -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"

src/haste-cat.hs view

@@ -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))) =

src/haste-copy-pkg.hs view

@@ -58,6 +58,6 @@     isKey key str =       and $ zipWith (==) key str     -    importDir  = "${pkgroot}" </> "libraries" </> "lib"+    importDir  = "${pkgroot}"     includeDir = "${pkgroot}" </> "include"     pkgRoot    = "${pkgroot}"

src/hastec.hs view

@@ -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 == "<!")+    then writeFile (replaceExtension outf "html") js+    else writeFile (replaceExtension outf "html") (htmlSkeleton outf js)+ -- | Use Haste or GHC for this command line?-chooseCompilerFor :: [String] -> 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"]

+ utils/haste-pkg/HastePkg708.hs view

@@ -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"

+ utils/haste-pkg/HastePkg710.hs view

@@ -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.+-}

utils/haste-pkg/haste-pkg.hs view

@@ -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