diff --git a/README.md b/README.md index ee703bcc22..202fffff16 100644 --- a/README.md +++ b/README.md @@ -10,6 +10,8 @@ The Unison language * [Codebase Server](#codebase-server) * [Configuration](./docs/configuration.md) +![Alt](https://repobeats.axiom.co/api/embed/92b662a65fd842d49cb8d7d813043f5f5b4b550d.svg "Repobeats analytics image") + Overview -------- diff --git a/lib/unison-util-recursion/src/Unison/Util/Recursion.hs b/lib/unison-util-recursion/src/Unison/Util/Recursion.hs index 3b0bb82dd8..e97ebae4db 100644 --- a/lib/unison-util-recursion/src/Unison/Util/Recursion.hs +++ b/lib/unison-util-recursion/src/Unison/Util/Recursion.hs @@ -8,12 +8,13 @@ module Unison.Util.Recursion cataM, para, Fix (..), - Cofree' (..), ) where import Control.Arrow ((&&&)) import Control.Comonad.Cofree (Cofree ((:<))) +import Control.Comonad.Trans.Cofree (CofreeF) +import Control.Comonad.Trans.Cofree qualified as CofreeF import Control.Monad ((<=<)) type Algebra f a = f a -> a @@ -46,12 +47,9 @@ instance (Functor f) => Recursive (Fix f) f where embed = Fix project (Fix f) = f -data Cofree' f a x = a :<< f x - deriving (Foldable, Functor, Traversable) - -- | -- -- __NB__: `Cofree` from “free” is lazy, so this instance is technically partial. -instance (Functor f) => Recursive (Cofree f a) (Cofree' f a) where - embed (a :<< fco) = a :< fco - project (a :< fco) = a :<< fco +instance (Functor f) => Recursive (Cofree f a) (CofreeF f a) where + embed (a CofreeF.:< fco) = a :< fco + project (a :< fco) = a CofreeF.:< fco diff --git a/parser-typechecker/src/Unison/Syntax/DeclParser.hs b/parser-typechecker/src/Unison/Syntax/DeclParser.hs index 38b5d0d2a8..734bb51b46 100644 --- a/parser-typechecker/src/Unison/Syntax/DeclParser.hs +++ b/parser-typechecker/src/Unison/Syntax/DeclParser.hs @@ -75,38 +75,25 @@ declarations = do data UnresolvedModifier = UnresolvedModifier'Structural | UnresolvedModifier'UniqueWithGuid !Text - | -- The Text here is a random GUID that we *may not end up using*, as in the case when we instead have a GUID to - -- reuse (which we will discover soon, once we parse this unique type's name and pass it into the `uniqueTypeGuid` - -- function in the parser environment). - -- - -- However, we generate this GUID anyway for backwards-compatibility with *transcripts*. Since the GUID we assign - -- is a function of the current source location in the parser state, if we generate it later (after moving a few - -- tokens ahead to the type's name), then we'll get a different value. - -- - -- This is only done to make the transcript diff smaller and easier to review, as the PR that adds this GUID-reuse - -- feature ought not to change any hashes. However, at any point after it lands in trunk, this Text could be - -- removed from this constructor, the generation of these GUIDs could be delayed until we actually need them, and - -- the transcripts could all be re-generated. - UnresolvedModifier'UniqueWithoutGuid !Text + | UnresolvedModifier'UniqueWithoutGuid resolveUnresolvedModifier :: (Monad m, Var v) => L.Token UnresolvedModifier -> v -> P v m (L.Token DD.Modifier) resolveUnresolvedModifier unresolvedModifier var = case L.payload unresolvedModifier of UnresolvedModifier'Structural -> pure (DD.Structural <$ unresolvedModifier) UnresolvedModifier'UniqueWithGuid guid -> pure (DD.Unique guid <$ unresolvedModifier) - UnresolvedModifier'UniqueWithoutGuid guid0 -> do - unique <- resolveUniqueModifier var guid0 + UnresolvedModifier'UniqueWithoutGuid -> do + unique <- resolveUniqueModifier var pure $ unique <$ unresolvedModifier -resolveUniqueModifier :: (Monad m, Var v) => v -> Text -> P v m DD.Modifier -resolveUniqueModifier var guid0 = do - ParsingEnv {uniqueTypeGuid} <- ask - guid <- fromMaybe guid0 <$> lift (lift (uniqueTypeGuid (Name.unsafeParseVar var))) - pure $ DD.Unique guid - -defaultUniqueModifier :: (Monad m, Var v) => v -> P v m DD.Modifier -defaultUniqueModifier var = - uniqueName 32 >>= resolveUniqueModifier var +resolveUniqueModifier :: (Monad m, Var v) => v -> P v m DD.Modifier +resolveUniqueModifier var = do + env <- ask + guid <- + lift (lift (env.uniqueTypeGuid (Name.unsafeParseVar var))) >>= \case + Nothing -> uniqueName 32 + Just guid -> pure guid + pure (DD.Unique guid) -- unique[someguid] type Blah = ... modifier :: (Monad m, Var v) => P v m (Maybe (L.Token UnresolvedModifier)) @@ -116,9 +103,7 @@ modifier = do unique = do tok <- openBlockWith "unique" optional (openBlockWith "[" *> importWordyId <* closeBlock) >>= \case - Nothing -> do - guid <- uniqueName 32 - pure (UnresolvedModifier'UniqueWithoutGuid guid <$ tok) + Nothing -> pure (UnresolvedModifier'UniqueWithoutGuid <$ tok) Just guid -> pure (UnresolvedModifier'UniqueWithGuid (Name.toText (L.payload guid)) <$ tok) structural = do tok <- openBlockWith "structural" @@ -196,7 +181,7 @@ dataDeclaration maybeUnresolvedModifier = do _ <- closeBlock case maybeUnresolvedModifier of Nothing -> do - modifier <- defaultUniqueModifier (L.payload name) + modifier <- resolveUniqueModifier (L.payload name) -- ann spanning the whole Decl. let declSpanAnn = ann typeToken <> closingAnn pure @@ -234,7 +219,7 @@ effectDeclaration maybeUnresolvedModifier = do case maybeUnresolvedModifier of Nothing -> do - modifier <- defaultUniqueModifier (L.payload name) + modifier <- resolveUniqueModifier (L.payload name) -- ann spanning the whole ability declaration. let abilitySpanAnn = ann abilityToken <> closingAnn pure diff --git a/parser-typechecker/src/Unison/Syntax/TermParser.hs b/parser-typechecker/src/Unison/Syntax/TermParser.hs index 90913645f0..97914aabfa 100644 --- a/parser-typechecker/src/Unison/Syntax/TermParser.hs +++ b/parser-typechecker/src/Unison/Syntax/TermParser.hs @@ -13,6 +13,7 @@ module Unison.Syntax.TermParser ) where +import Control.Comonad.Trans.Cofree (CofreeF ((:<))) import Control.Monad.Reader (asks, local) import Data.Bitraversable (bitraverse) import Data.Char qualified as Char @@ -607,7 +608,7 @@ doc2Block = do let docAnn = Ann startDoc endDoc (docAnn,) . docUntitledSection (gann docAnn) <$> traverse foldTop docContents where - foldTop = cataM \(a :<< top) -> docTop a =<< bitraverse (cataM \(a :<< leaf) -> docLeaf a leaf) pure top + foldTop = cataM \(a :< top) -> docTop a =<< bitraverse (cataM \(a :< leaf) -> docLeaf a leaf) pure top gann :: (Annotated a) => a -> Ann gann = Ann.GeneratedFrom . ann diff --git a/parser-typechecker/src/Unison/UnisonFile.hs b/parser-typechecker/src/Unison/UnisonFile.hs index 785482bac6..b3b8a12e1d 100644 --- a/parser-typechecker/src/Unison/UnisonFile.hs +++ b/parser-typechecker/src/Unison/UnisonFile.hs @@ -33,6 +33,7 @@ module Unison.UnisonFile nonEmpty, termSignatureExternalLabeledDependencies, topLevelComponents, + typecheckedToTypeLookup, typecheckedUnisonFile, Unison.UnisonFile.rewrite, prepareRewrite, @@ -368,6 +369,15 @@ declsToTypeLookup uf = where wrangle = Map.fromList . Map.elems +typecheckedToTypeLookup :: TypecheckedUnisonFile v a -> TL.TypeLookup v a +typecheckedToTypeLookup tuf = + TL.TypeLookup + mempty + (wrangle (dataDeclarations' tuf)) + (wrangle (effectDeclarations' tuf)) + where + wrangle = Map.fromList . Map.elems + -- Returns true if the file has any definitions or watches nonEmpty :: TypecheckedUnisonFile v a -> Bool nonEmpty uf = diff --git a/parser-typechecker/src/Unison/Util/EnumContainers.hs b/parser-typechecker/src/Unison/Util/EnumContainers.hs index fe62ee69d7..b227ad3ee7 100644 --- a/parser-typechecker/src/Unison/Util/EnumContainers.hs +++ b/parser-typechecker/src/Unison/Util/EnumContainers.hs @@ -43,11 +43,15 @@ class EnumKey k where intToKey :: Int -> k instance EnumKey Word64 where + {-# INLINE keyToInt #-} keyToInt e = fromIntegral e + {-# INLINE intToKey #-} intToKey i = fromIntegral i instance EnumKey Word16 where + {-# INLINE keyToInt #-} keyToInt e = fromIntegral e + {-# INLINE intToKey #-} intToKey i = fromIntegral i newtype EnumMap k a = EM (IM.IntMap a) @@ -77,24 +81,31 @@ newtype EnumSet k = ES IS.IntSet Semigroup ) +{-# INLINE mapFromList #-} mapFromList :: (EnumKey k) => [(k, a)] -> EnumMap k a mapFromList = EM . IM.fromList . fmap (first keyToInt) +{-# INLINE setFromList #-} setFromList :: (EnumKey k) => [k] -> EnumSet k setFromList = ES . IS.fromList . fmap keyToInt +{-# INLINE setToList #-} setToList :: (EnumKey k) => EnumSet k -> [k] setToList (ES s) = intToKey <$> IS.toList s +{-# INLINE mapSingleton #-} mapSingleton :: (EnumKey k) => k -> a -> EnumMap k a mapSingleton e a = EM $ IM.singleton (keyToInt e) a +{-# INLINE setSingleton #-} setSingleton :: (EnumKey k) => k -> EnumSet k setSingleton e = ES . IS.singleton $ keyToInt e +{-# INLINE mapInsert #-} mapInsert :: (EnumKey k) => k -> a -> EnumMap k a -> EnumMap k a mapInsert e x (EM m) = EM $ IM.insert (keyToInt e) x m +{-# INLINE unionWith #-} unionWith :: (EnumKey k) => (a -> a -> a) -> @@ -103,6 +114,7 @@ unionWith :: EnumMap k a unionWith f (EM l) (EM r) = EM $ IM.unionWith f l r +{-# INLINE intersectionWith #-} intersectionWith :: (a -> b -> c) -> EnumMap k a -> @@ -110,53 +122,69 @@ intersectionWith :: EnumMap k c intersectionWith f (EM l) (EM r) = EM $ IM.intersectionWith f l r +{-# INLINE keys #-} keys :: (EnumKey k) => EnumMap k a -> [k] keys (EM m) = fmap intToKey . IM.keys $ m +{-# INLINE keysSet #-} keysSet :: (EnumKey k) => EnumMap k a -> EnumSet k keysSet (EM m) = ES (IM.keysSet m) +{-# INLINE restrictKeys #-} restrictKeys :: (EnumKey k) => EnumMap k a -> EnumSet k -> EnumMap k a restrictKeys (EM m) (ES s) = EM $ IM.restrictKeys m s +{-# INLINE withoutKeys #-} withoutKeys :: (EnumKey k) => EnumMap k a -> EnumSet k -> EnumMap k a withoutKeys (EM m) (ES s) = EM $ IM.withoutKeys m s +{-# INLINE mapDifference #-} mapDifference :: (EnumKey k) => EnumMap k a -> EnumMap k b -> EnumMap k a mapDifference (EM l) (EM r) = EM $ IM.difference l r +{-# INLINE member #-} member :: (EnumKey k) => k -> EnumSet k -> Bool member e (ES s) = IS.member (keyToInt e) s +{-# INLINE hasKey #-} hasKey :: (EnumKey k) => k -> EnumMap k a -> Bool hasKey k (EM m) = IM.member (keyToInt k) m +{-# INLINE lookup #-} lookup :: (EnumKey k) => k -> EnumMap k a -> Maybe a lookup e (EM m) = IM.lookup (keyToInt e) m +{-# INLINE lookupWithDefault #-} lookupWithDefault :: (EnumKey k) => a -> k -> EnumMap k a -> a lookupWithDefault d e (EM m) = IM.findWithDefault d (keyToInt e) m +{-# INLINE mapWithKey #-} mapWithKey :: (EnumKey k) => (k -> a -> b) -> EnumMap k a -> EnumMap k b mapWithKey f (EM m) = EM $ IM.mapWithKey (f . intToKey) m +{-# INLINE foldMapWithKey #-} foldMapWithKey :: (EnumKey k) => (Monoid m) => (k -> a -> m) -> EnumMap k a -> m foldMapWithKey f (EM m) = IM.foldMapWithKey (f . intToKey) m +{-# INLINE mapToList #-} mapToList :: (EnumKey k) => EnumMap k a -> [(k, a)] mapToList (EM m) = first intToKey <$> IM.toList m +{-# INLINE (!) #-} (!) :: (EnumKey k) => EnumMap k a -> k -> a (!) (EM m) e = m IM.! keyToInt e +{-# INLINE findMin #-} findMin :: (EnumKey k) => EnumSet k -> k findMin (ES s) = intToKey $ IS.findMin s +{-# INLINE traverseSet_ #-} traverseSet_ :: (Applicative f) => (EnumKey k) => (k -> f ()) -> EnumSet k -> f () traverseSet_ f (ES s) = IS.foldr (\i r -> f (intToKey i) *> r) (pure ()) s +{-# INLINE interverse #-} interverse :: (Applicative f) => (a -> b -> f c) -> @@ -166,6 +194,7 @@ interverse :: interverse f (EM l) (EM r) = fmap EM . traverse id $ IM.intersectionWith f l r +{-# INLINE traverseWithKey #-} traverseWithKey :: (Applicative f) => (EnumKey k) => @@ -174,5 +203,6 @@ traverseWithKey :: f (EnumMap k b) traverseWithKey f (EM m) = EM <$> IM.traverseWithKey (f . intToKey) m +{-# INLINE setSize #-} setSize :: EnumSet k -> Int setSize (ES s) = IS.size s diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 7f585cb329..4967878424 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1469,7 +1469,9 @@ displayI outputLoc hq = do let filePPED = PPED.makePPED (PPE.hqNamer 10 namesWithDefinitionsFromFile) (suffixify namesWithDefinitionsFromFile) let suffixifiedFilePPE = PPE.biasTo bias $ PPE.suffixifiedPPE filePPED - (_, watches) <- evalUnisonFile Sandboxed suffixifiedFilePPE unisonFile [] + (_, watches) <- + evalUnisonFile Sandboxed suffixifiedFilePPE unisonFile [] & onLeftM \err -> + Cli.returnEarly (Output.EvaluationFailure err) (_, _, _, _, tm, _) <- Map.lookup toDisplay watches & onNothing (error $ "Evaluation dropped a watch expression: " <> Text.unpack (HQ.toText hq)) let ns = UF.addNamesFromTypeCheckedUnisonFile unisonFile names diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Load.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Load.hs index 350ae30b09..dd1f62eb02 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Load.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Load.hs @@ -77,11 +77,13 @@ loadUnisonFile sourceName text = do when (not . null $ UF.watchComponents unisonFile) do Timing.time "evaluating watches" do - (bindings, e) <- evalUnisonFile Permissive ppe unisonFile [] - let e' = Map.map go e - go (ann, kind, _hash, _uneval, eval, isHit) = (ann, kind, eval, isHit) - when (not (null e')) do - Cli.respond $ Output.Evaluated text ppe bindings e' + evalUnisonFile Permissive ppe unisonFile [] >>= \case + Right (bindings, e) -> do + when (not (null e)) do + let f (ann, kind, _hash, _uneval, eval, isHit) = (ann, kind, eval, isHit) + Cli.respond $ Output.Evaluated text ppe bindings (Map.map f e) + Left err -> Cli.respond (Output.EvaluationFailure err) + #latestTypecheckedFile .= Just (Right unisonFile) where withFile :: @@ -174,29 +176,34 @@ evalUnisonFile :: TypecheckedUnisonFile Symbol Ann -> [String] -> Cli - ( [(Symbol, Term Symbol ())], - Map Symbol (Ann, WK.WatchKind, Reference.Id, Term Symbol (), Term Symbol (), Bool) + ( Either + Runtime.Error + ( [(Symbol, Term Symbol ())], + Map Symbol (Ann, WK.WatchKind, Reference.Id, Term Symbol (), Term Symbol (), Bool) + ) ) evalUnisonFile mode ppe unisonFile args = do - Cli.Env {codebase, runtime, sandboxedRuntime, nativeRuntime} <- ask + env <- ask + let theRuntime = case mode of - Sandboxed -> sandboxedRuntime - Permissive -> runtime - Native -> nativeRuntime + Sandboxed -> env.sandboxedRuntime + Permissive -> env.runtime + Native -> env.nativeRuntime let watchCache :: Reference.Id -> IO (Maybe (Term Symbol ())) watchCache ref = do - maybeTerm <- Codebase.runTransaction codebase (Codebase.lookupWatchCache codebase ref) + maybeTerm <- Codebase.runTransaction env.codebase (Codebase.lookupWatchCache env.codebase ref) pure (Term.amap (\(_ :: Ann) -> ()) <$> maybeTerm) Cli.with_ (withArgs args) do - (nts, errs, map) <- - Cli.ioE (Runtime.evaluateWatches (Codebase.codebaseToCodeLookup codebase) ppe watchCache theRuntime unisonFile) \err -> do - Cli.returnEarly (Output.EvaluationFailure err) - when (not $ null errs) (RuntimeUtils.displayDecompileErrors errs) - for_ (Map.elems map) \(_loc, kind, hash, _src, value, isHit) -> do - -- only update the watch cache when there are no errors - when (not isHit && null errs) do - let value' = Term.amap (\() -> Ann.External) value - Cli.runTransaction (Codebase.putWatch kind hash value') - pure (nts, map) + let codeLookup = Codebase.codebaseToCodeLookup env.codebase + liftIO (Runtime.evaluateWatches codeLookup ppe watchCache theRuntime unisonFile) >>= \case + Right (nts, errs, map) -> do + when (not $ null errs) (RuntimeUtils.displayDecompileErrors errs) + for_ (Map.elems map) \(_loc, kind, hash, _src, value, isHit) -> do + -- only update the watch cache when there are no errors + when (not isHit && null errs) do + let value' = Term.amap (\() -> Ann.External) value + Cli.runTransaction (Codebase.putWatch kind hash value') + pure (Right (nts, map)) + Left err -> pure (Left err) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Run.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Run.hs index 9cf1cbeaff..91d0329c6c 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Run.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Run.hs @@ -42,6 +42,7 @@ import Unison.UnisonFile (TypecheckedUnisonFile) import Unison.UnisonFile qualified as UF import Unison.UnisonFile.Names qualified as UF import Unison.Util.Defns (Defns (..)) +import Unison.Util.Monoid qualified as Monoid import Unison.Util.Recursion import Unison.Var qualified as Var @@ -56,7 +57,9 @@ handleRun native main args = do let pped = PPED.makePPED (PPE.hqNamer 10 namesWithFileDefinitions) (PPE.suffixifyByHash namesWithFileDefinitions) let suffixifiedPPE = PPED.suffixifiedPPE pped let mode | native = Native | otherwise = Permissive - (_, xs) <- evalUnisonFile mode suffixifiedPPE unisonFile args + (_, xs) <- + evalUnisonFile mode suffixifiedPPE unisonFile args & onLeftM \err -> + Cli.returnEarly (Output.EvaluationFailure err) mainRes :: Term Symbol () <- case lookup magicMainWatcherString (map bonk (Map.toList xs)) of Nothing -> @@ -110,7 +113,7 @@ getTerm' mainName = mainToFile (MainTerm.BadType _ ty) = pure $ maybe NoTermWithThatName TermHasBadType ty mainToFile (MainTerm.Success hq tm typ) = let v = Var.named (HQ.toText hq) - in checkType typ \otyp -> + in checkType Nothing typ \otyp -> pure (GetTermSuccess (v, tm, typ, otyp)) getFromFile uf = do let components = join $ UF.topLevelComponents uf @@ -118,21 +121,22 @@ getTerm' mainName = let mainComponent = filter ((\v -> Var.name v == HQ.toText mainName) . view _1) components case mainComponent of [(v, _, tm, ty)] -> - checkType ty \otyp -> + checkType (Just uf) ty \otyp -> let runMain = DD.forceTerm a a (Term.var a v) v2 = Var.freshIn (Set.fromList [v]) v a = ABT.annotation tm in pure (GetTermSuccess (v2, runMain, ty, otyp)) _ -> getFromCodebase - checkType :: Type Symbol Ann -> (Type Symbol Ann -> Cli GetTermResult) -> Cli GetTermResult - checkType ty f = do + checkType :: Maybe (TypecheckedUnisonFile Symbol Ann) -> Type Symbol Ann -> (Type Symbol Ann -> Cli GetTermResult) -> Cli GetTermResult + checkType mayTuf ty f = do Cli.Env {codebase, runtime} <- ask case Typechecker.fitsScheme ty (Runtime.mainType runtime) of True -> do - typeLookup <- + tlCodebase <- Cli.runTransaction $ Codebase.typeLookupForDependencies codebase Defns {terms = Set.empty, types = Type.dependencies ty} - f $! synthesizeForce typeLookup ty + let tlTuf = Monoid.fromMaybe (fmap UF.typecheckedToTypeLookup mayTuf) + f $! synthesizeForce (tlTuf <> tlCodebase) ty False -> pure (TermHasBadType ty) in Cli.getLatestTypecheckedFile >>= \case Nothing -> getFromCodebase diff --git a/unison-cli/src/Unison/Codebase/Transcript.hs b/unison-cli/src/Unison/Codebase/Transcript.hs index 81d56e7e8c..590c9f8d28 100644 --- a/unison-cli/src/Unison/Codebase/Transcript.hs +++ b/unison-cli/src/Unison/Codebase/Transcript.hs @@ -3,6 +3,7 @@ -- | The data model for Unison transcripts. module Unison.Codebase.Transcript ( ExpectingError, + HasBug, ScratchFileName, Hidden (..), UcmLine (..), @@ -25,6 +26,8 @@ import Unison.Project (ProjectAndBranch) type ExpectingError = Bool +type HasBug = Bool + type ScratchFileName = Text data Hidden = Shown | HideOutput | HideAll @@ -56,13 +59,14 @@ type Stanza = Either CMark.Node ProcessedBlock data InfoTags a = InfoTags { hidden :: Hidden, expectingError :: ExpectingError, + hasBug :: HasBug, generated :: Bool, additionalTags :: a } deriving (Eq, Ord, Read, Show) defaultInfoTags :: a -> InfoTags a -defaultInfoTags = InfoTags Shown False False +defaultInfoTags = InfoTags Shown False False False -- | If the `additionalTags` form a `Monoid`, then you don’t need to provide a default value for them. defaultInfoTags' :: (Monoid a) => InfoTags a diff --git a/unison-cli/src/Unison/Codebase/Transcript/Parser.hs b/unison-cli/src/Unison/Codebase/Transcript/Parser.hs index 4943b5442a..cc335e9f7c 100644 --- a/unison-cli/src/Unison/Codebase/Transcript/Parser.hs +++ b/unison-cli/src/Unison/Codebase/Transcript/Parser.hs @@ -23,7 +23,7 @@ import Data.Char qualified as Char import Data.Text qualified as Text import Text.Megaparsec qualified as P import Text.Megaparsec.Char qualified as P -import Unison.Codebase.Transcript hiding (expectingError, generated, hidden) +import Unison.Codebase.Transcript hiding (expectingError, generated, hasBug, hidden) import Unison.Prelude import Unison.Project (fullyQualifiedProjectAndBranchNamesParser) @@ -50,9 +50,9 @@ formatStanzas = processedBlockToNode :: ProcessedBlock -> CMark.Node processedBlockToNode = \case - Ucm tags cmds -> mkNode (\() -> "") "ucm" tags $ foldr ((<>) . formatUcmLine) "" cmds - Unison tags txt -> mkNode (maybe "" (" " <>)) "unison" tags txt - API tags apiRequests -> mkNode (\() -> "") "api" tags $ foldr ((<>) . formatAPIRequest) "" apiRequests + Ucm tags cmds -> mkNode (\() -> Nothing) "ucm" tags $ foldr ((<>) . formatUcmLine) "" cmds + Unison tags txt -> mkNode id "unison" tags txt + API tags apiRequests -> mkNode (\() -> Nothing) "api" tags $ foldr ((<>) . formatAPIRequest) "" apiRequests where mkNode formatA lang = CMarkCodeBlock Nothing . formatInfoString formatA lang @@ -98,20 +98,28 @@ apiRequest = <|> APIComment <$> (P.chunk "--" *> restOfLine) <|> APIResponseLine <$> (P.chunk " " *> restOfLine <|> "" <$ P.single '\n' <|> "" <$ P.chunk " \n") -formatInfoString :: (a -> Text) -> Text -> InfoTags a -> Text +formatInfoString :: (a -> Maybe Text) -> Text -> InfoTags a -> Text formatInfoString formatA language infoTags = let infoTagText = formatInfoTags formatA infoTags in if Text.null infoTagText then language else language <> " " <> infoTagText -formatInfoTags :: (a -> Text) -> InfoTags a -> Text -formatInfoTags formatA (InfoTags hidden expectingError generated additionalTags) = - formatHidden hidden <> formatExpectingError expectingError <> formatGenerated generated <> formatA additionalTags +formatInfoTags :: (a -> Maybe Text) -> InfoTags a -> Text +formatInfoTags formatA (InfoTags hidden expectingError hasBug generated additionalTags) = + Text.intercalate " " $ + catMaybes + [ formatHidden hidden, + formatExpectingError expectingError, + formatHasBug hasBug, + formatGenerated generated, + formatA additionalTags + ] infoTags :: P a -> P (InfoTags a) infoTags p = InfoTags <$> lineToken hidden <*> lineToken expectingError + <*> lineToken hasBug <*> lineToken generated <*> p <* P.single '\n' @@ -135,26 +143,32 @@ lineToken p = p <* nonNewlineSpaces nonNewlineSpaces :: P () nonNewlineSpaces = void $ P.takeWhileP Nothing (\ch -> ch == ' ' || ch == '\t') -formatHidden :: Hidden -> Text +formatHidden :: Hidden -> Maybe Text formatHidden = \case - HideAll -> ":hide:all" - HideOutput -> ":hide" - Shown -> "" + HideAll -> pure ":hide-all" + HideOutput -> pure ":hide" + Shown -> Nothing hidden :: P Hidden hidden = - (HideAll <$ word ":hide:all") + (HideAll <$ word ":hide-all") <|> (HideOutput <$ word ":hide") <|> pure Shown -formatExpectingError :: ExpectingError -> Text -formatExpectingError = bool "" ":error" +formatExpectingError :: ExpectingError -> Maybe Text +formatExpectingError = bool Nothing $ pure ":error" expectingError :: P ExpectingError expectingError = isJust <$> optional (word ":error") -formatGenerated :: ExpectingError -> Text -formatGenerated = bool "" ":added-by-ucm" +formatHasBug :: HasBug -> Maybe Text +formatHasBug = bool Nothing $ pure ":bug" + +hasBug :: P HasBug +hasBug = isJust <$> optional (word ":bug") + +formatGenerated :: ExpectingError -> Maybe Text +formatGenerated = bool Nothing $ pure ":added-by-ucm" generated :: P Bool generated = isJust <$> optional (word ":added-by-ucm") diff --git a/unison-cli/src/Unison/Codebase/Transcript/Runner.hs b/unison-cli/src/Unison/Codebase/Transcript/Runner.hs index 9c06e31da8..97082cfab5 100644 --- a/unison-cli/src/Unison/Codebase/Transcript/Runner.hs +++ b/unison-cli/src/Unison/Codebase/Transcript/Runner.hs @@ -171,6 +171,7 @@ run isTest verbosity dir codebase runtime sbRuntime nRuntime ucmVersion baseURL currentTags <- newIORef Nothing isHidden <- newIORef Shown allowErrors <- newIORef False + expectFailure <- newIORef False hasErrors <- newIORef False mBlock <- newIORef Nothing let patternMap = Map.fromList $ (\p -> (patternName p, p) : ((,p) <$> aliases p)) =<< validInputs @@ -204,12 +205,25 @@ run isTest verbosity dir codebase runtime sbRuntime nRuntime ucmVersion baseURL -- We shorten the terminal width, because "Transcript" manages a 2-space indent for output lines. Pretty.toPlain (terminalWidth - 2) line - maybeDieWithMsg :: String -> IO () + maybeDieWithMsg :: Pretty.Pretty Pretty.ColorText -> IO () maybeDieWithMsg msg = do - errOk <- readIORef allowErrors - if errOk - then writeIORef hasErrors True - else dieWithMsg msg + liftIO $ writeIORef hasErrors True + liftIO (liftA2 (,) (readIORef allowErrors) (readIORef expectFailure)) >>= \case + (False, False) -> liftIO . dieWithMsg $ Pretty.toPlain terminalWidth msg + (True, True) -> do + appendFailingStanza + fixedBug out $ + Text.unlines + [ "The stanza above marked with `:error :bug` is now failing with", + "", + "```", + Text.pack $ Pretty.toPlain terminalWidth msg, + "```", + "", + "so you can remove `:bug` and close any appropriate Github issues. If the error message is different \ + \from the expected error message, open a new issue and reference it in this transcript." + ] + (_, _) -> pure () apiRequest :: APIRequest -> IO [APIRequest] apiRequest req = do @@ -220,9 +234,13 @@ run isTest verbosity dir codebase runtime sbRuntime nRuntime ucmVersion baseURL APIComment {} -> pure $ pure req GetRequest path -> either - (([] <$) . maybeDieWithMsg . show) + (([] <$) . maybeDieWithMsg . Pretty.string . show) ( either - (([] <$) . maybeDieWithMsg . (("Error decoding response from " <> Text.unpack path <> ": ") <>)) + ( ([] <$) + . maybeDieWithMsg + . (("Error decoding response from " <> Pretty.text path <> ": ") <>) + . Pretty.string + ) ( \(v :: Aeson.Value) -> pure $ if hide @@ -309,12 +327,9 @@ run isTest verbosity dir codebase runtime sbRuntime nRuntime ucmVersion baseURL >>= either -- invalid command is treated as a failure ( \msg -> do - liftIO $ writeIORef hasErrors True - liftIO (readIORef allowErrors) >>= \case - True -> do - liftIO $ outputUcmResult msg - Cli.returnEarlyWithoutOutput - False -> liftIO . dieWithMsg $ Pretty.toPlain terminalWidth msg + liftIO $ outputUcmResult msg + liftIO $ maybeDieWithMsg msg + Cli.returnEarlyWithoutOutput ) -- No input received from this line, try again. (maybe Cli.returnEarlyWithoutOutput $ pure . Right . snd) @@ -325,6 +340,7 @@ run isTest verbosity dir codebase runtime sbRuntime nRuntime ucmVersion baseURL writeIORef isHidden $ hidden infoTags outputEcho $ pure block writeIORef allowErrors $ expectingError infoTags + writeIORef expectFailure $ hasBug infoTags -- Open a ucm block which will contain the output from UCM after processing the `UnisonFileChanged` event. -- Close the ucm block after processing the UnisonFileChanged event. atomically . Q.enqueue cmdQueue $ Nothing @@ -335,6 +351,7 @@ run isTest verbosity dir codebase runtime sbRuntime nRuntime ucmVersion baseURL liftIO do writeIORef isHidden $ hidden infoTags writeIORef allowErrors $ expectingError infoTags + writeIORef expectFailure $ hasBug infoTags outputEcho . pure . API infoTags . fold =<< traverse apiRequest apiRequests Cli.returnEarlyWithoutOutput Ucm infoTags cmds -> do @@ -342,6 +359,7 @@ run isTest verbosity dir codebase runtime sbRuntime nRuntime ucmVersion baseURL writeIORef currentTags $ pure infoTags writeIORef isHidden $ hidden infoTags writeIORef allowErrors $ expectingError infoTags + writeIORef expectFailure $ hasBug infoTags writeIORef hasErrors False traverse_ (atomically . Q.enqueue cmdQueue . Just) cmds atomically . Q.enqueue cmdQueue $ Nothing @@ -382,6 +400,7 @@ run isTest verbosity dir codebase runtime sbRuntime nRuntime ucmVersion baseURL liftIO $ writeIORef currentTags Nothing liftIO $ writeIORef isHidden Shown liftIO $ writeIORef allowErrors False + liftIO $ writeIORef expectFailure False maybe (liftIO finishTranscript) (uncurry processStanza) =<< atomically (Q.tryDequeue inputQueue) awaitInput :: Cli (Either Event Input) @@ -409,22 +428,14 @@ run isTest verbosity dir codebase runtime sbRuntime nRuntime ucmVersion baseURL print :: Output.Output -> IO () print o = do msg <- notifyUser dir o - errOk <- readIORef allowErrors outputUcmResult msg - when (Output.isFailure o) $ - if errOk - then writeIORef hasErrors True - else dieWithMsg $ Pretty.toPlain terminalWidth msg + when (Output.isFailure o) $ maybeDieWithMsg msg printNumbered :: Output.NumberedOutput -> IO Output.NumberedArgs printNumbered o = do let (msg, numberedArgs) = notifyNumbered o - errOk <- readIORef allowErrors outputUcmResult msg - when (Output.isNumberedFailure o) $ - if errOk - then writeIORef hasErrors True - else dieWithMsg $ Pretty.toPlain terminalWidth msg + when (Output.isNumberedFailure o) $ maybeDieWithMsg msg pure numberedArgs -- Looks at the current stanza and decides if it is contained in the @@ -447,13 +458,21 @@ run isTest verbosity dir codebase runtime sbRuntime nRuntime ucmVersion baseURL dieUnexpectedSuccess :: IO () dieUnexpectedSuccess = do errOk <- readIORef allowErrors + expectBug <- readIORef expectFailure hasErr <- readIORef hasErrors - when (errOk && not hasErr) $ do - appendFailingStanza - transcriptFailure - out - "The transcript was expecting an error in the stanza above, but did not encounter one." - Nothing + case (errOk, expectBug, hasErr) of + (True, False, False) -> do + appendFailingStanza + transcriptFailure + out + "The transcript was expecting an error in the stanza above, but did not encounter one." + Nothing + (False, True, False) -> do + fixedBug + out + "The stanza above with `:bug` is now passing! You can remove `:bug` and close any appropriate Github \ + \issues." + (_, _, _) -> pure () authenticatedHTTPClient <- AuthN.newAuthenticatedHTTPClient tokenProvider ucmVersion @@ -508,6 +527,22 @@ transcriptFailure out heading mbody = do <> foldr ((:) . CMarkCodeBlock Nothing "") [] mbody ) +fixedBug :: IORef (Seq Stanza) -> Text -> IO b +fixedBug out body = do + texts <- readIORef out + -- `CMark.commonmarkToNode` returns a @DOCUMENT@, which won’t be rendered inside another document, so we strip the + -- outer `CMark.Node`. + let CMark.Node _ _DOCUMENT bodyNodes = CMark.commonmarkToNode [CMark.optNormalize] body + UnliftIO.throwIO . RunFailure $ + texts + <> Seq.fromList + ( Left + <$> [ CMark.Node Nothing CMark.PARAGRAPH [CMark.Node Nothing (CMark.TEXT "🎉") []], + CMark.Node Nothing (CMark.HEADING 2) [CMark.Node Nothing (CMark.TEXT "You fixed a bug!") []] + ] + <> bodyNodes + ) + data Error = ParseError (P.ParseErrorBundle Text Void) | RunFailure (Seq Stanza) diff --git a/unison-cli/src/Unison/Main.hs b/unison-cli/src/Unison/Main.hs index 3624a50675..59845f0608 100644 --- a/unison-cli/src/Unison/Main.hs +++ b/unison-cli/src/Unison/Main.hs @@ -238,7 +238,7 @@ main version = do Right (Right (v, rf, combIx, sto)) | not vmatch -> mismatchMsg | otherwise -> - withArgs args (RTI.runStandalone sto combIx) >>= \case + withArgs args (RTI.runStandalone False sto combIx) >>= \case Left err -> exitError err Right () -> pure () where diff --git a/unison-runtime/src/Unison/Runtime/ANF.hs b/unison-runtime/src/Unison/Runtime/ANF.hs index 259987f07c..539b6bcd66 100644 --- a/unison-runtime/src/Unison/Runtime/ANF.hs +++ b/unison-runtime/src/Unison/Runtime/ANF.hs @@ -42,7 +42,6 @@ module Unison.Runtime.ANF SuperGroup (..), arities, POp (..), - FOp, close, saturate, float, @@ -117,6 +116,7 @@ import Unison.Prelude import Unison.Reference (Id, Reference, Reference' (Builtin, DerivedId)) import Unison.Referent (Referent, pattern Con, pattern Ref) import Unison.Runtime.Array qualified as PA +import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..)) import Unison.Runtime.TypeTags (CTag (..), PackedTag (..), RTag (..), Tag (..), maskTags, packTags, unpackTags) import Unison.Symbol (Symbol) import Unison.Term hiding (List, Ref, Text, arity, float, fresh, resolve) @@ -1030,12 +1030,12 @@ pattern TPrm :: ABTN.Term ANormalF v pattern TPrm p args = TApp (FPrim (Left p)) args -pattern AFOp :: FOp -> [v] -> ANormalF v e +pattern AFOp :: ForeignFunc -> [v] -> ANormalF v e pattern AFOp p args = AApp (FPrim (Right p)) args pattern TFOp :: (ABT.Var v) => - FOp -> + ForeignFunc -> [v] -> ABTN.Term ANormalF v pattern TFOp p args = TApp (FPrim (Right p)) args @@ -1232,9 +1232,6 @@ instance Semigroup (BranchAccum v) where instance Monoid (BranchAccum e) where mempty = AccumEmpty --- Foreign operation, indexed by words -type FOp = Word64 - data Func v = -- variable FVar v @@ -1247,7 +1244,7 @@ data Func v | -- ability request FReq !Reference !CTag | -- prim op - FPrim (Either POp FOp) + FPrim (Either POp ForeignFunc) deriving (Show, Eq, Functor, Foldable, Traversable) data Lit diff --git a/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs index 9b6c575232..4b0759ad0f 100644 --- a/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs +++ b/unison-runtime/src/Unison/Runtime/ANF/Serialize.hs @@ -25,8 +25,8 @@ import Unison.ABT.Normalized (Term (..)) import Unison.Reference (Reference, Reference' (Builtin), pattern Derived) import Unison.Runtime.ANF as ANF hiding (Tag) import Unison.Runtime.Exception +import Unison.Runtime.Foreign.Function.Type (ForeignFunc) import Unison.Runtime.Serialize -import Unison.Util.EnumContainers qualified as EC import Unison.Util.Text qualified as Util.Text import Unison.Var (Type (ANFBlank), Var (..)) import Prelude hiding (getChar, putChar) @@ -317,7 +317,7 @@ putGroup :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap FOp Text -> + Map ForeignFunc Text -> SuperGroup v -> m () putGroup refrep fops (Rec bs e) = @@ -338,7 +338,7 @@ getGroup = do cs <- replicateM l (getComb ctx n) Rec (zip vs cs) <$> getComb ctx n -putCode :: (MonadPut m) => EC.EnumMap FOp Text -> Code -> m () +putCode :: (MonadPut m) => Map ForeignFunc Text -> Code -> m () putCode fops (CodeRep g c) = putGroup mempty fops g *> putCacheability c getCode :: (MonadGet m) => Word32 -> m Code @@ -363,7 +363,7 @@ putComb :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap FOp Text -> + Map ForeignFunc Text -> [v] -> SuperNormal v -> m () @@ -384,7 +384,7 @@ putNormal :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap FOp Text -> + Map ForeignFunc Text -> [v] -> ANormal v -> m () @@ -482,7 +482,7 @@ putFunc :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap FOp Text -> + Map ForeignFunc Text -> [v] -> Func v -> m () @@ -496,7 +496,7 @@ putFunc refrep fops ctx f = case f of FReq r c -> putTag FReqT *> putReference r *> putCTag c FPrim (Left p) -> putTag FPrimT *> putPOp p FPrim (Right f) - | Just nm <- EC.lookup f fops -> + | Just nm <- Map.lookup f fops -> putTag FForeignT *> putText nm | otherwise -> exn $ "putFunc: could not serialize foreign operation: " ++ show f @@ -757,7 +757,7 @@ putBranches :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap FOp Text -> + Map ForeignFunc Text -> [v] -> Branched (ANormal v) -> m () @@ -825,7 +825,7 @@ putCase :: (MonadPut m) => (Var v) => Map Reference Word64 -> - EC.EnumMap FOp Text -> + Map ForeignFunc Text -> [v] -> ([Mem], ANormal v) -> m () @@ -997,7 +997,7 @@ deserializeCode bs = runGetS (getVersion >>= getCode) bs n | 1 <= n && n <= 3 -> pure n n -> fail $ "deserializeGroup: unknown version: " ++ show n -serializeCode :: EC.EnumMap FOp Text -> Code -> ByteString +serializeCode :: Map ForeignFunc Text -> Code -> ByteString serializeCode fops co = runPutS (putVersion *> putCode fops co) where putVersion = putWord32be codeVersion @@ -1023,7 +1023,7 @@ serializeCode fops co = runPutS (putVersion *> putCode fops co) -- shouldn't be subject to rehashing. serializeGroupForRehash :: (Var v) => - EC.EnumMap FOp Text -> + Map ForeignFunc Text -> Reference -> SuperGroup v -> L.ByteString diff --git a/unison-runtime/src/Unison/Runtime/Builtin.hs b/unison-runtime/src/Unison/Runtime/Builtin.hs index 6c292f4a78..f6e610cdf7 100644 --- a/unison-runtime/src/Unison/Runtime/Builtin.hs +++ b/unison-runtime/src/Unison/Runtime/Builtin.hs @@ -8,186 +8,42 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Unison.Runtime.Builtin - ( builtinLookup, - builtinTermNumbering, + ( builtinTermNumbering, builtinTypeNumbering, builtinTermBackref, builtinTypeBackref, - builtinForeigns, builtinArities, builtinInlineInfo, - sandboxedForeigns, numberedTermLookup, Sandbox (..), baseSandboxInfo, + unitValue, + natValue, + builtinForeignNames, + sandboxedForeignFuncs, ) where -import Control.Concurrent (ThreadId) -import Control.Concurrent as SYS - ( killThread, - threadDelay, - ) -import Control.Concurrent.MVar as SYS -import Control.Concurrent.STM qualified as STM -import Control.DeepSeq (NFData) -import Control.Exception (evaluate) -import Control.Exception.Safe qualified as Exception -import Control.Monad.Catch (MonadCatch) -import Control.Monad.Primitive qualified as PA -import Control.Monad.Reader (ReaderT (..), ask, runReaderT) import Control.Monad.State.Strict (State, execState, modify) -import Crypto.Error (CryptoError (..), CryptoFailable (..)) -import Crypto.Hash qualified as Hash -import Crypto.MAC.HMAC qualified as HMAC -import Crypto.PubKey.Ed25519 qualified as Ed25519 -import Crypto.PubKey.RSA.PKCS15 qualified as RSA -import Crypto.Random (getRandomBytes) -import Data.Bits (shiftL, shiftR, (.|.)) -import Data.ByteArray qualified as BA -import Data.ByteString (hGet, hGetSome, hPut) -import Data.ByteString.Lazy qualified as L -import Data.Default (def) -import Data.Digest.Murmur64 (asWord64, hash64) -import Data.IP (IP) import Data.Map qualified as Map -import Data.PEM (PEM, pemContent, pemParseLBS) import Data.Set (insert) import Data.Set qualified as Set import Data.Text qualified -import Data.Text.IO qualified as Text.IO -import Data.Time.Clock.POSIX as SYS - ( getPOSIXTime, - posixSecondsToUTCTime, - utcTimeToPOSIXSeconds, - ) -import Data.Time.LocalTime (TimeZone (..), getTimeZone) -import Data.X509 qualified as X -import Data.X509.CertificateStore qualified as X -import Data.X509.Memory qualified as X -import GHC.Conc qualified as STM -import GHC.IO (IO (IO)) -import Network.Simple.TCP as SYS - ( HostPreference (..), - bindSock, - closeSock, - connectSock, - listenSock, - recv, - send, - ) -import Network.Socket as SYS - ( PortNumber, - Socket, - accept, - socketPort, - ) -import Network.TLS as TLS -import Network.TLS.Extra.Cipher as Cipher -import Network.UDP as UDP - ( ClientSockAddr, - ListenSocket, - UDPSocket (..), - clientSocket, - close, - recv, - recvFrom, - send, - sendTo, - serverSocket, - stop, - ) -import System.Clock (Clock (..), getTime, nsec, sec) -import System.Directory as SYS - ( createDirectoryIfMissing, - doesDirectoryExist, - doesPathExist, - getCurrentDirectory, - getDirectoryContents, - getFileSize, - getModificationTime, - getTemporaryDirectory, - removeDirectoryRecursive, - removeFile, - renameDirectory, - renameFile, - setCurrentDirectory, - ) -import System.Environment as SYS - ( getArgs, - getEnv, - ) -import System.Exit as SYS (ExitCode (..)) -import System.FilePath (isPathSeparator) -import System.IO (Handle) -import System.IO as SYS - ( IOMode (..), - hClose, - hGetBuffering, - hGetChar, - hGetEcho, - hIsEOF, - hIsOpen, - hIsSeekable, - hReady, - hSeek, - hSetBuffering, - hSetEcho, - hTell, - openFile, - stderr, - stdin, - stdout, - ) -import System.IO.Temp (createTempDirectory) -import System.Process as SYS - ( getProcessExitCode, - proc, - runInteractiveProcess, - terminateProcess, - waitForProcess, - withCreateProcess, - ) -import System.X509 qualified as X import Unison.ABT.Normalized hiding (TTm) import Unison.Builtin.Decls qualified as Ty import Unison.Prelude hiding (Text, some) import Unison.Reference -import Unison.Referent (Referent, pattern Ref) import Unison.Runtime.ANF as ANF -import Unison.Runtime.ANF.Rehash (checkGroupHashes) -import Unison.Runtime.ANF.Serialize as ANF -import Unison.Runtime.Array qualified as PA import Unison.Runtime.Builtin.Types -import Unison.Runtime.Crypto.Rsa as Rsa -import Unison.Runtime.Exception (die) -import Unison.Runtime.Foreign - ( Foreign (Wrap), - HashAlgorithm (..), - pattern Failure, - ) -import Unison.Runtime.Foreign qualified as F -import Unison.Runtime.Foreign.Function -import Unison.Runtime.Stack (UnboxedTypeTag (..), Val (..), emptyVal, unboxedTypeTagToInt) +import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..), foreignFuncBuiltinName) +import Unison.Runtime.Stack (UnboxedTypeTag (..), Val (..), unboxedTypeTagToInt) import Unison.Runtime.Stack qualified as Closure import Unison.Symbol import Unison.Type qualified as Ty -import Unison.Util.Bytes qualified as Bytes import Unison.Util.EnumContainers as EC -import Unison.Util.RefPromise - ( Promise, - newPromise, - readPromise, - tryReadPromise, - writePromise, - ) -import Unison.Util.Text (Text) import Unison.Util.Text qualified as Util.Text -import Unison.Util.Text.Pattern qualified as TPat import Unison.Var -type Failure = F.Failure Val - freshes :: (Var v) => Int -> [v] freshes = freshes' mempty @@ -887,7 +743,7 @@ stm'atomic = where (act, unit, lz) = fresh -type ForeignOp = FOp -> ([Mem], ANormal Symbol) +type ForeignOp = ForeignFunc -> ([Mem], ANormal Symbol) standard'handle :: ForeignOp standard'handle instr = @@ -1116,30 +972,30 @@ crypto'hmac instr = -- -- () -> ... -inUnit :: forall v. (Var v) => v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) +inUnit :: forall v. (Var v) => v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) inUnit unit result cont instr = ([BX], TAbs unit $ TLetD result UN (TFOp instr []) cont) -inN :: forall v. (Var v) => [v] -> v -> ANormal v -> FOp -> ([Mem], ANormal v) +inN :: forall v. (Var v) => [v] -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) inN args result cont instr = (args $> BX,) . TAbss args $ TLetD result UN (TFOp instr args) cont -- a -> ... -in1 :: forall v. (Var v) => v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) +in1 :: forall v. (Var v) => v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) in1 arg result cont instr = inN [arg] result cont instr -- a -> b -> ... -in2 :: forall v. (Var v) => v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) +in2 :: forall v. (Var v) => v -> v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) in2 arg1 arg2 result cont instr = inN [arg1, arg2] result cont instr -- a -> b -> c -> ... -in3 :: forall v. (Var v) => v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) +in3 :: forall v. (Var v) => v -> v -> v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) in3 arg1 arg2 arg3 result cont instr = inN [arg1, arg2, arg3] result cont instr -- Maybe a -> b -> ... -inMaybeBx :: forall v. (Var v) => v -> v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) +inMaybeBx :: forall v. (Var v) => v -> v -> v -> v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) inMaybeBx arg1 arg2 arg3 mb result cont instr = ([BX, BX],) . TAbss [arg1, arg2] @@ -1166,7 +1022,7 @@ set'echo instr = (arg1, arg2, bol, stack1, stack2, stack3, unit, fail, result) = fresh -- a -> IOMode -> ... -inIomr :: forall v. (Var v) => v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) +inIomr :: forall v. (Var v) => v -> v -> v -> v -> ANormal v -> ForeignFunc -> ([Mem], ANormal v) inIomr arg1 arg2 fm result cont instr = ([BX, BX],) . TAbss [arg1, arg2] @@ -1834,8 +1690,7 @@ builtinLookup = ] ++ foreignWrappers -type FDecl v = - ReaderT Bool (State (Word64, [(Data.Text.Text, (Sandbox, SuperNormal v))], EnumMap Word64 (Data.Text.Text, ForeignFunc))) +type FDecl v = State (Map ForeignFunc (Sandbox, SuperNormal v)) -- Data type to determine whether a builtin should be tracked for -- sandboxing. Untracked means that it can be freely used, and Tracked @@ -1844,38 +1699,15 @@ type FDecl v = data Sandbox = Tracked | Untracked deriving (Eq, Ord, Show, Read, Enum, Bounded) -bomb :: Data.Text.Text -> a -> IO r -bomb name _ = die $ "attempted to use sandboxed operation: " ++ Data.Text.unpack name - declareForeign :: Sandbox -> - Data.Text.Text -> ForeignOp -> ForeignFunc -> FDecl Symbol () -declareForeign sand name op func0 = do - sanitize <- ask - modify $ \(w, codes, funcs) -> - let func - | sanitize, - Tracked <- sand, - FF r w _ <- func0 = - FF r w (bomb name) - | otherwise = func0 - code = (name, (sand, uncurry Lambda (op w))) - in (w + 1, code : codes, mapInsert w (name, func) funcs) - -mkForeignIOF :: - (ForeignConvention a, ForeignConvention r) => - (a -> IO r) -> - ForeignFunc -mkForeignIOF f = mkForeign $ \a -> tryIOE (f a) - where - tryIOE :: IO a -> IO (Either Failure a) - tryIOE = fmap handleIOE . try - handleIOE :: Either IOException a -> Either Failure a - handleIOE (Left e) = Left $ Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue - handleIOE (Right a) = Right a +declareForeign sand op func = do + modify $ \funcs -> + let code = uncurry Lambda (op func) + in (Map.insert func (sand, code) funcs) unitValue :: Val unitValue = BoxedVal $ Closure.Enum Ty.unitRef (PackedTag 0) @@ -1883,1279 +1715,378 @@ unitValue = BoxedVal $ Closure.Enum Ty.unitRef (PackedTag 0) natValue :: Word64 -> Val natValue w = NatVal w -mkForeignTls :: - forall a r. - (ForeignConvention a, ForeignConvention r) => - (a -> IO r) -> - ForeignFunc -mkForeignTls f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) - where - tryIO1 :: IO r -> IO (Either TLS.TLSException r) - tryIO1 = try - tryIO2 :: IO (Either TLS.TLSException r) -> IO (Either IOException (Either TLS.TLSException r)) - tryIO2 = try - flatten :: Either IOException (Either TLS.TLSException r) -> Either (Failure) r - flatten (Left e) = Left (Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Left e)) = Left (Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Right a)) = Right a - -mkForeignTlsE :: - forall a r. - (ForeignConvention a, ForeignConvention r) => - (a -> IO (Either Failure r)) -> - ForeignFunc -mkForeignTlsE f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) - where - tryIO1 :: IO (Either Failure r) -> IO (Either TLS.TLSException (Either Failure r)) - tryIO1 = try - tryIO2 :: IO (Either TLS.TLSException (Either Failure r)) -> IO (Either IOException (Either TLS.TLSException (Either Failure r))) - tryIO2 = try - flatten :: Either IOException (Either TLS.TLSException (Either Failure r)) -> Either Failure r - flatten (Left e) = Left (Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Left e)) = Left (Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) - flatten (Right (Right (Left e))) = Left e - flatten (Right (Right (Right a))) = Right a - declareUdpForeigns :: FDecl Symbol () declareUdpForeigns = do - declareForeign Tracked "IO.UDP.clientSocket.impl.v1" arg2ToEF - . mkForeignIOF - $ \(host :: Util.Text.Text, port :: Util.Text.Text) -> - let hostStr = Util.Text.toString host - portStr = Util.Text.toString port - in UDP.clientSocket hostStr portStr True - - declareForeign Tracked "IO.UDP.UDPSocket.recv.impl.v1" argToEF - . mkForeignIOF - $ \(sock :: UDPSocket) -> Bytes.fromArray <$> UDP.recv sock - - declareForeign Tracked "IO.UDP.UDPSocket.send.impl.v1" arg2ToEF0 - . mkForeignIOF - $ \(sock :: UDPSocket, bytes :: Bytes.Bytes) -> - UDP.send sock (Bytes.toArray bytes) - - declareForeign Tracked "IO.UDP.UDPSocket.close.impl.v1" argToEF0 - . mkForeignIOF - $ \(sock :: UDPSocket) -> UDP.close sock - - declareForeign Tracked "IO.UDP.ListenSocket.close.impl.v1" argToEF0 - . mkForeignIOF - $ \(sock :: ListenSocket) -> UDP.stop sock - - declareForeign Tracked "IO.UDP.UDPSocket.toText.impl.v1" (argNDirect 1) - . mkForeign - $ \(sock :: UDPSocket) -> pure $ show sock - - declareForeign Tracked "IO.UDP.serverSocket.impl.v1" arg2ToEF - . mkForeignIOF - $ \(ip :: Util.Text.Text, port :: Util.Text.Text) -> - let maybeIp = readMaybe $ Util.Text.toString ip :: Maybe IP - maybePort = readMaybe $ Util.Text.toString port :: Maybe PortNumber - in case (maybeIp, maybePort) of - (Nothing, _) -> fail "Invalid IP Address" - (_, Nothing) -> fail "Invalid Port Number" - (Just ip, Just pt) -> UDP.serverSocket (ip, pt) - - declareForeign Tracked "IO.UDP.ListenSocket.toText.impl.v1" (argNDirect 1) - . mkForeign - $ \(sock :: ListenSocket) -> pure $ show sock - - declareForeign Tracked "IO.UDP.ListenSocket.recvFrom.impl.v1" argToEFTup - . mkForeignIOF - $ fmap (first Bytes.fromArray) <$> UDP.recvFrom - - declareForeign Tracked "IO.UDP.ClientSockAddr.toText.v1" (argNDirect 1) - . mkForeign - $ \(sock :: ClientSockAddr) -> pure $ show sock - - declareForeign Tracked "IO.UDP.ListenSocket.sendTo.impl.v1" arg3ToEF0 - . mkForeignIOF - $ \(socket :: ListenSocket, bytes :: Bytes.Bytes, addr :: ClientSockAddr) -> - UDP.sendTo socket (Bytes.toArray bytes) addr - -declareForeigns :: FDecl Symbol () -declareForeigns = do - declareUdpForeigns - declareForeign Tracked "IO.openFile.impl.v3" argIomrToEF $ - mkForeignIOF $ \(fnameText :: Util.Text.Text, n :: Int) -> - let fname = Util.Text.toString fnameText - mode = case n of - 0 -> ReadMode - 1 -> WriteMode - 2 -> AppendMode - _ -> ReadWriteMode - in openFile fname mode - - declareForeign Tracked "IO.closeFile.impl.v3" argToEF0 $ mkForeignIOF hClose - declareForeign Tracked "IO.isFileEOF.impl.v3" argToEFBool $ mkForeignIOF hIsEOF - declareForeign Tracked "IO.isFileOpen.impl.v3" argToEFBool $ mkForeignIOF hIsOpen - declareForeign Tracked "IO.getEcho.impl.v1" argToEFBool $ mkForeignIOF hGetEcho - declareForeign Tracked "IO.ready.impl.v1" argToEFBool $ mkForeignIOF hReady - declareForeign Tracked "IO.getChar.impl.v1" argToEFChar $ mkForeignIOF hGetChar - declareForeign Tracked "IO.isSeekable.impl.v3" argToEFBool $ mkForeignIOF hIsSeekable - - declareForeign Tracked "IO.seekHandle.impl.v3" seek'handle - . mkForeignIOF - $ \(h, sm, n) -> hSeek h sm (fromIntegral (n :: Int)) - - declareForeign Tracked "IO.handlePosition.impl.v3" argToEFNat - -- TODO: truncating integer - . mkForeignIOF - $ \h -> fromInteger @Word64 <$> hTell h + declareForeign Tracked arg2ToEF IO_UDP_clientSocket_impl_v1 - declareForeign Tracked "IO.getBuffering.impl.v3" get'buffering $ - mkForeignIOF hGetBuffering + declareForeign Tracked argToEF IO_UDP_UDPSocket_recv_impl_v1 - declareForeign Tracked "IO.setBuffering.impl.v3" set'buffering - . mkForeignIOF - $ uncurry hSetBuffering + declareForeign Tracked arg2ToEF0 IO_UDP_UDPSocket_send_impl_v1 + declareForeign Tracked argToEF0 IO_UDP_UDPSocket_close_impl_v1 - declareForeign Tracked "IO.setEcho.impl.v1" set'echo . mkForeignIOF $ uncurry hSetEcho + declareForeign Tracked argToEF0 IO_UDP_ListenSocket_close_impl_v1 - declareForeign Tracked "IO.getLine.impl.v1" argToEF $ - mkForeignIOF $ - fmap Util.Text.fromText . Text.IO.hGetLine + declareForeign Tracked (argNDirect 1) IO_UDP_UDPSocket_toText_impl_v1 - declareForeign Tracked "IO.getBytes.impl.v3" arg2ToEF . mkForeignIOF $ - \(h, n) -> Bytes.fromArray <$> hGet h n + declareForeign Tracked arg2ToEF IO_UDP_serverSocket_impl_v1 - declareForeign Tracked "IO.getSomeBytes.impl.v1" arg2ToEF . mkForeignIOF $ - \(h, n) -> Bytes.fromArray <$> hGetSome h n + declareForeign Tracked (argNDirect 1) IO_UDP_ListenSocket_toText_impl_v1 - declareForeign Tracked "IO.putBytes.impl.v3" arg2ToEF0 . mkForeignIOF $ \(h, bs) -> hPut h (Bytes.toArray bs) + declareForeign Tracked argToEFTup IO_UDP_ListenSocket_recvFrom_impl_v1 - declareForeign Tracked "IO.systemTime.impl.v3" unitToEF $ - mkForeignIOF $ - \() -> getPOSIXTime + declareForeign Tracked (argNDirect 1) IO_UDP_ClientSockAddr_toText_v1 - declareForeign Tracked "IO.systemTimeMicroseconds.v1" unitToR $ - mkForeign $ - \() -> fmap (1e6 *) getPOSIXTime + declareForeign Tracked arg3ToEF0 IO_UDP_ListenSocket_sendTo_impl_v1 - declareForeign Tracked "Clock.internals.monotonic.v1" unitToEF $ - mkForeignIOF $ - \() -> getTime Monotonic - - declareForeign Tracked "Clock.internals.realtime.v1" unitToEF $ - mkForeignIOF $ - \() -> getTime Realtime - - declareForeign Tracked "Clock.internals.processCPUTime.v1" unitToEF $ - mkForeignIOF $ - \() -> getTime ProcessCPUTime - - declareForeign Tracked "Clock.internals.threadCPUTime.v1" unitToEF $ - mkForeignIOF $ - \() -> getTime ThreadCPUTime - - declareForeign Tracked "Clock.internals.sec.v1" (argNDirect 1) $ - mkForeign (\n -> pure (fromIntegral $ sec n :: Word64)) - - -- A TimeSpec that comes from getTime never has negative nanos, - -- so we can safely cast to Nat - declareForeign Tracked "Clock.internals.nsec.v1" (argNDirect 1) $ - mkForeign (\n -> pure (fromIntegral $ nsec n :: Word64)) - - declareForeign Tracked "Clock.internals.systemTimeZone.v1" time'zone $ - mkForeign - ( \secs -> do - TimeZone offset summer name <- getTimeZone (posixSecondsToUTCTime (fromIntegral (secs :: Int))) - pure (offset :: Int, summer, name) - ) - - let chop = reverse . dropWhile isPathSeparator . reverse - - declareForeign Tracked "IO.getTempDirectory.impl.v3" unitToEF $ - mkForeignIOF $ - \() -> chop <$> getTemporaryDirectory +declareForeigns :: FDecl Symbol () +declareForeigns = do + declareUdpForeigns + declareForeign Tracked argIomrToEF IO_openFile_impl_v3 - declareForeign Tracked "IO.createTempDirectory.impl.v3" argToEF $ - mkForeignIOF $ \prefix -> do - temp <- getTemporaryDirectory - chop <$> createTempDirectory temp prefix + declareForeign Tracked argToEF0 IO_closeFile_impl_v3 + declareForeign Tracked argToEFBool IO_isFileEOF_impl_v3 + declareForeign Tracked argToEFBool IO_isFileOpen_impl_v3 + declareForeign Tracked argToEFBool IO_getEcho_impl_v1 + declareForeign Tracked argToEFBool IO_ready_impl_v1 + declareForeign Tracked argToEFChar IO_getChar_impl_v1 + declareForeign Tracked argToEFBool IO_isSeekable_impl_v3 - declareForeign Tracked "IO.getCurrentDirectory.impl.v3" unitToEF - . mkForeignIOF - $ \() -> getCurrentDirectory + declareForeign Tracked seek'handle IO_seekHandle_impl_v3 - declareForeign Tracked "IO.setCurrentDirectory.impl.v3" argToEF0 $ - mkForeignIOF setCurrentDirectory + declareForeign Tracked argToEFNat IO_handlePosition_impl_v3 - declareForeign Tracked "IO.fileExists.impl.v3" argToEFBool $ - mkForeignIOF doesPathExist + declareForeign Tracked get'buffering IO_getBuffering_impl_v3 - declareForeign Tracked "IO.getEnv.impl.v1" argToEF $ - mkForeignIOF getEnv + declareForeign Tracked set'buffering IO_setBuffering_impl_v3 - declareForeign Tracked "IO.getArgs.impl.v1" unitToEF $ - mkForeignIOF $ - \() -> fmap Util.Text.pack <$> SYS.getArgs + declareForeign Tracked set'echo IO_setEcho_impl_v1 - declareForeign Tracked "IO.isDirectory.impl.v3" argToEFBool $ - mkForeignIOF doesDirectoryExist + declareForeign Tracked argToEF IO_getLine_impl_v1 - declareForeign Tracked "IO.createDirectory.impl.v3" argToEF0 $ - mkForeignIOF $ - createDirectoryIfMissing True + declareForeign Tracked arg2ToEF IO_getBytes_impl_v3 + declareForeign Tracked arg2ToEF IO_getSomeBytes_impl_v1 + declareForeign Tracked arg2ToEF0 IO_putBytes_impl_v3 + declareForeign Tracked unitToEF IO_systemTime_impl_v3 - declareForeign Tracked "IO.removeDirectory.impl.v3" argToEF0 $ - mkForeignIOF removeDirectoryRecursive + declareForeign Tracked unitToR IO_systemTimeMicroseconds_v1 - declareForeign Tracked "IO.renameDirectory.impl.v3" arg2ToEF0 $ - mkForeignIOF $ - uncurry renameDirectory + declareForeign Tracked unitToEF Clock_internals_monotonic_v1 - declareForeign Tracked "IO.directoryContents.impl.v3" argToEF $ - mkForeignIOF $ - (fmap Util.Text.pack <$>) . getDirectoryContents + declareForeign Tracked unitToEF Clock_internals_realtime_v1 - declareForeign Tracked "IO.removeFile.impl.v3" argToEF0 $ - mkForeignIOF removeFile + declareForeign Tracked unitToEF Clock_internals_processCPUTime_v1 - declareForeign Tracked "IO.renameFile.impl.v3" arg2ToEF0 $ - mkForeignIOF $ - uncurry renameFile + declareForeign Tracked unitToEF Clock_internals_threadCPUTime_v1 - declareForeign Tracked "IO.getFileTimestamp.impl.v3" argToEFNat - . mkForeignIOF - $ fmap utcTimeToPOSIXSeconds . getModificationTime + declareForeign Tracked (argNDirect 1) Clock_internals_sec_v1 - declareForeign Tracked "IO.getFileSize.impl.v3" argToEFNat - -- TODO: truncating integer - . mkForeignIOF - $ \fp -> fromInteger @Word64 <$> getFileSize fp + -- A TimeSpec that comes from getTime never has negative nanos, + -- so we can safely cast to Nat + declareForeign Tracked (argNDirect 1) Clock_internals_nsec_v1 - declareForeign Tracked "IO.serverSocket.impl.v3" maybeToEF - . mkForeignIOF - $ \( mhst :: Maybe Util.Text.Text, - port - ) -> - fst <$> SYS.bindSock (hostPreference mhst) port + declareForeign Tracked time'zone Clock_internals_systemTimeZone_v1 - declareForeign Tracked "Socket.toText" (argNDirect 1) - . mkForeign - $ \(sock :: Socket) -> pure $ show sock + declareForeign Tracked unitToEF IO_getTempDirectory_impl_v3 - declareForeign Tracked "Handle.toText" (argNDirect 1) - . mkForeign - $ \(hand :: Handle) -> pure $ show hand + declareForeign Tracked argToEF IO_createTempDirectory_impl_v3 - declareForeign Tracked "ThreadId.toText" (argNDirect 1) - . mkForeign - $ \(threadId :: ThreadId) -> pure $ show threadId + declareForeign Tracked unitToEF IO_getCurrentDirectory_impl_v3 - declareForeign Tracked "IO.socketPort.impl.v3" argToEFNat - . mkForeignIOF - $ \(handle :: Socket) -> do - n <- SYS.socketPort handle - return (fromIntegral n :: Word64) + declareForeign Tracked argToEF0 IO_setCurrentDirectory_impl_v3 - declareForeign Tracked "IO.listen.impl.v3" argToEF0 - . mkForeignIOF - $ \sk -> SYS.listenSock sk 2048 + declareForeign Tracked argToEFBool IO_fileExists_impl_v3 - declareForeign Tracked "IO.clientSocket.impl.v3" arg2ToEF - . mkForeignIOF - $ fmap fst . uncurry SYS.connectSock + declareForeign Tracked argToEF IO_getEnv_impl_v1 - declareForeign Tracked "IO.closeSocket.impl.v3" argToEF0 $ - mkForeignIOF SYS.closeSock + declareForeign Tracked unitToEF IO_getArgs_impl_v1 - declareForeign Tracked "IO.socketAccept.impl.v3" argToEF - . mkForeignIOF - $ fmap fst . SYS.accept + declareForeign Tracked argToEFBool IO_isDirectory_impl_v3 - declareForeign Tracked "IO.socketSend.impl.v3" arg2ToEF0 - . mkForeignIOF - $ \(sk, bs) -> SYS.send sk (Bytes.toArray bs) + declareForeign Tracked argToEF0 IO_createDirectory_impl_v3 - declareForeign Tracked "IO.socketReceive.impl.v3" arg2ToEF - . mkForeignIOF - $ \(hs, n) -> - maybe mempty Bytes.fromArray <$> SYS.recv hs n + declareForeign Tracked argToEF0 IO_removeDirectory_impl_v3 - declareForeign Tracked "IO.kill.impl.v3" argToEF0 $ mkForeignIOF killThread + declareForeign Tracked arg2ToEF0 IO_renameDirectory_impl_v3 - let mx :: Word64 - mx = fromIntegral (maxBound :: Int) + declareForeign Tracked argToEF IO_directoryContents_impl_v3 - customDelay :: Word64 -> IO () - customDelay n - | n < mx = threadDelay (fromIntegral n) - | otherwise = threadDelay maxBound >> customDelay (n - mx) + declareForeign Tracked argToEF0 IO_removeFile_impl_v3 - declareForeign Tracked "IO.delay.impl.v3" argToEFUnit $ - mkForeignIOF customDelay + declareForeign Tracked arg2ToEF0 IO_renameFile_impl_v3 - declareForeign Tracked "IO.stdHandle" standard'handle - . mkForeign - $ \(n :: Int) -> case n of - 0 -> pure SYS.stdin - 1 -> pure SYS.stdout - 2 -> pure SYS.stderr - _ -> die "IO.stdHandle: invalid input." + declareForeign Tracked argToEFNat IO_getFileTimestamp_impl_v3 - let exitDecode ExitSuccess = 0 - exitDecode (ExitFailure n) = n + declareForeign Tracked argToEFNat IO_getFileSize_impl_v3 - declareForeign Tracked "IO.process.call" (argNDirect 2) . mkForeign $ - \(exe, map Util.Text.unpack -> args) -> - withCreateProcess (proc exe args) $ \_ _ _ p -> - exitDecode <$> waitForProcess p + declareForeign Tracked maybeToEF IO_serverSocket_impl_v3 - declareForeign Tracked "IO.process.start" start'process . mkForeign $ - \(exe, map Util.Text.unpack -> args) -> - runInteractiveProcess exe args Nothing Nothing + declareForeign Tracked (argNDirect 1) Socket_toText - declareForeign Tracked "IO.process.kill" argToUnit . mkForeign $ - terminateProcess - - declareForeign Tracked "IO.process.wait" (argNDirect 1) . mkForeign $ - \ph -> exitDecode <$> waitForProcess ph - - declareForeign Tracked "IO.process.exitCode" argToMaybe . mkForeign $ - fmap (fmap exitDecode) . getProcessExitCode + declareForeign Tracked (argNDirect 1) Handle_toText - declareForeign Tracked "MVar.new" (argNDirect 1) - . mkForeign - $ \(c :: Val) -> newMVar c + declareForeign Tracked (argNDirect 1) ThreadId_toText - declareForeign Tracked "MVar.newEmpty.v2" unitDirect - . mkForeign - $ \() -> newEmptyMVar @Val + declareForeign Tracked argToEFNat IO_socketPort_impl_v3 - declareForeign Tracked "MVar.take.impl.v3" argToEF - . mkForeignIOF - $ \(mv :: MVar Val) -> takeMVar mv + declareForeign Tracked argToEF0 IO_listen_impl_v3 - declareForeign Tracked "MVar.tryTake" argToMaybe - . mkForeign - $ \(mv :: MVar Val) -> tryTakeMVar mv + declareForeign Tracked arg2ToEF IO_clientSocket_impl_v3 - declareForeign Tracked "MVar.put.impl.v3" arg2ToEF0 - . mkForeignIOF - $ \(mv :: MVar Val, x) -> putMVar mv x + declareForeign Tracked argToEF0 IO_closeSocket_impl_v3 - declareForeign Tracked "MVar.tryPut.impl.v3" arg2ToEFBool - . mkForeignIOF - $ \(mv :: MVar Val, x) -> tryPutMVar mv x + declareForeign Tracked argToEF IO_socketAccept_impl_v3 - declareForeign Tracked "MVar.swap.impl.v3" arg2ToEF - . mkForeignIOF - $ \(mv :: MVar Val, x) -> swapMVar mv x + declareForeign Tracked arg2ToEF0 IO_socketSend_impl_v3 - declareForeign Tracked "MVar.isEmpty" (argNDirect 1) - . mkForeign - $ \(mv :: MVar Val) -> isEmptyMVar mv + declareForeign Tracked arg2ToEF IO_socketReceive_impl_v3 - declareForeign Tracked "MVar.read.impl.v3" argToEF - . mkForeignIOF - $ \(mv :: MVar Val) -> readMVar mv + declareForeign Tracked argToEF0 IO_kill_impl_v3 - declareForeign Tracked "MVar.tryRead.impl.v3" argToEFM - . mkForeignIOF - $ \(mv :: MVar Val) -> tryReadMVar mv + declareForeign Tracked argToEFUnit IO_delay_impl_v3 - declareForeign Untracked "Char.toText" (argNDirect 1) . mkForeign $ - \(ch :: Char) -> pure (Util.Text.singleton ch) + declareForeign Tracked standard'handle IO_stdHandle - declareForeign Untracked "Text.repeat" (argNDirect 2) . mkForeign $ - \(n :: Word64, txt :: Util.Text.Text) -> pure (Util.Text.replicate (fromIntegral n) txt) + declareForeign Tracked (argNDirect 2) IO_process_call - declareForeign Untracked "Text.reverse" (argNDirect 1) . mkForeign $ - pure . Util.Text.reverse + declareForeign Tracked start'process IO_process_start - declareForeign Untracked "Text.toUppercase" (argNDirect 1) . mkForeign $ - pure . Util.Text.toUppercase + declareForeign Tracked argToUnit IO_process_kill - declareForeign Untracked "Text.toLowercase" (argNDirect 1) . mkForeign $ - pure . Util.Text.toLowercase + declareForeign Tracked (argNDirect 1) IO_process_wait - declareForeign Untracked "Text.toUtf8" (argNDirect 1) . mkForeign $ - pure . Util.Text.toUtf8 + declareForeign Tracked argToMaybe IO_process_exitCode + declareForeign Tracked (argNDirect 1) MVar_new - declareForeign Untracked "Text.fromUtf8.impl.v3" argToEF . mkForeign $ - pure . mapLeft (\t -> Failure Ty.ioFailureRef (Util.Text.pack t) unitValue) . Util.Text.fromUtf8 + declareForeign Tracked unitDirect MVar_newEmpty_v2 - declareForeign Tracked "Tls.ClientConfig.default" (argNDirect 2) . mkForeign $ - \(hostName :: Util.Text.Text, serverId :: Bytes.Bytes) -> - fmap - ( \store -> - (defaultParamsClient (Util.Text.unpack hostName) (Bytes.toArray serverId)) - { TLS.clientSupported = def {TLS.supportedCiphers = Cipher.ciphersuite_strong}, - TLS.clientShared = def {TLS.sharedCAStore = store} - } - ) - X.getSystemCertificateStore + declareForeign Tracked argToEF MVar_take_impl_v3 - declareForeign Tracked "Tls.ServerConfig.default" (argNDirect 2) $ - mkForeign $ - \(certs :: [X.SignedCertificate], key :: X.PrivKey) -> - pure $ - (def :: TLS.ServerParams) - { TLS.serverSupported = def {TLS.supportedCiphers = Cipher.ciphersuite_strong}, - TLS.serverShared = def {TLS.sharedCredentials = Credentials [(X.CertificateChain certs, key)]} - } + declareForeign Tracked argToMaybe MVar_tryTake - let updateClient :: X.CertificateStore -> TLS.ClientParams -> TLS.ClientParams - updateClient certs client = client {TLS.clientShared = ((clientShared client) {TLS.sharedCAStore = certs})} - in declareForeign Tracked "Tls.ClientConfig.certificates.set" (argNDirect 2) . mkForeign $ - \(certs :: [X.SignedCertificate], params :: ClientParams) -> pure $ updateClient (X.makeCertificateStore certs) params + declareForeign Tracked arg2ToEF0 MVar_put_impl_v3 - let updateServer :: X.CertificateStore -> TLS.ServerParams -> TLS.ServerParams - updateServer certs client = client {TLS.serverShared = ((serverShared client) {TLS.sharedCAStore = certs})} - in declareForeign Tracked "Tls.ServerConfig.certificates.set" (argNDirect 2) . mkForeign $ - \(certs :: [X.SignedCertificate], params :: ServerParams) -> pure $ updateServer (X.makeCertificateStore certs) params + declareForeign Tracked arg2ToEFBool MVar_tryPut_impl_v3 - declareForeign Tracked "TVar.new" (argNDirect 1) . mkForeign $ - \(c :: Val) -> unsafeSTMToIO $ STM.newTVar c + declareForeign Tracked arg2ToEF MVar_swap_impl_v3 - declareForeign Tracked "TVar.read" (argNDirect 1) . mkForeign $ - \(v :: STM.TVar Val) -> unsafeSTMToIO $ STM.readTVar v + declareForeign Tracked (argNDirect 1) MVar_isEmpty - declareForeign Tracked "TVar.write" arg2To0 . mkForeign $ - \(v :: STM.TVar Val, c :: Val) -> - unsafeSTMToIO $ STM.writeTVar v c + declareForeign Tracked argToEF MVar_read_impl_v3 - declareForeign Tracked "TVar.newIO" (argNDirect 1) . mkForeign $ - \(c :: Val) -> STM.newTVarIO c + declareForeign Tracked argToEFM MVar_tryRead_impl_v3 - declareForeign Tracked "TVar.readIO" (argNDirect 1) . mkForeign $ - \(v :: STM.TVar Val) -> STM.readTVarIO v + declareForeign Untracked (argNDirect 1) Char_toText + declareForeign Untracked (argNDirect 2) Text_repeat + declareForeign Untracked (argNDirect 1) Text_reverse + declareForeign Untracked (argNDirect 1) Text_toUppercase + declareForeign Untracked (argNDirect 1) Text_toLowercase + declareForeign Untracked (argNDirect 1) Text_toUtf8 + declareForeign Untracked argToEF Text_fromUtf8_impl_v3 + declareForeign Tracked (argNDirect 2) Tls_ClientConfig_default + declareForeign Tracked (argNDirect 2) Tls_ServerConfig_default + declareForeign Tracked (argNDirect 2) Tls_ClientConfig_certificates_set - declareForeign Tracked "TVar.swap" (argNDirect 2) . mkForeign $ - \(v, c :: Val) -> unsafeSTMToIO $ STM.swapTVar v c + declareForeign Tracked (argNDirect 2) Tls_ServerConfig_certificates_set - declareForeign Tracked "STM.retry" unitDirect . mkForeign $ - \() -> unsafeSTMToIO STM.retry :: IO Val + declareForeign Tracked (argNDirect 1) TVar_new - declareForeign Tracked "Promise.new" unitDirect . mkForeign $ - \() -> newPromise @Val + declareForeign Tracked (argNDirect 1) TVar_read + declareForeign Tracked arg2To0 TVar_write + declareForeign Tracked (argNDirect 1) TVar_newIO + declareForeign Tracked (argNDirect 1) TVar_readIO + declareForeign Tracked (argNDirect 2) TVar_swap + declareForeign Tracked unitDirect STM_retry + declareForeign Tracked unitDirect Promise_new -- the only exceptions from Promise.read are async and shouldn't be caught - declareForeign Tracked "Promise.read" (argNDirect 1) . mkForeign $ - \(p :: Promise Val) -> readPromise p - - declareForeign Tracked "Promise.tryRead" argToMaybe . mkForeign $ - \(p :: Promise Val) -> tryReadPromise p - - declareForeign Tracked "Promise.write" (argNDirect 2) . mkForeign $ - \(p :: Promise Val, a :: Val) -> writePromise p a - - declareForeign Tracked "Tls.newClient.impl.v3" arg2ToEF . mkForeignTls $ - \( config :: TLS.ClientParams, - socket :: SYS.Socket - ) -> TLS.contextNew socket config - - declareForeign Tracked "Tls.newServer.impl.v3" arg2ToEF . mkForeignTls $ - \( config :: TLS.ServerParams, - socket :: SYS.Socket - ) -> TLS.contextNew socket config - - declareForeign Tracked "Tls.handshake.impl.v3" argToEF0 . mkForeignTls $ - \(tls :: TLS.Context) -> TLS.handshake tls - - declareForeign Tracked "Tls.send.impl.v3" arg2ToEF0 . mkForeignTls $ - \( tls :: TLS.Context, - bytes :: Bytes.Bytes - ) -> TLS.sendData tls (Bytes.toLazyByteString bytes) - - let wrapFailure t = Failure Ty.tlsFailureRef (Util.Text.pack t) unitValue - decoded :: Bytes.Bytes -> Either String PEM - decoded bytes = case pemParseLBS $ Bytes.toLazyByteString bytes of - Right (pem : _) -> Right pem - Right [] -> Left "no PEM found" - Left l -> Left l - asCert :: PEM -> Either String X.SignedCertificate - asCert pem = X.decodeSignedCertificate $ pemContent pem - in declareForeign Tracked "Tls.decodeCert.impl.v3" argToEF . mkForeignTlsE $ - \(bytes :: Bytes.Bytes) -> pure $ mapLeft wrapFailure $ (decoded >=> asCert) bytes - - declareForeign Tracked "Tls.encodeCert" (argNDirect 1) . mkForeign $ - \(cert :: X.SignedCertificate) -> pure $ Bytes.fromArray $ X.encodeSignedObject cert - - declareForeign Tracked "Tls.decodePrivateKey" (argNDirect 1) . mkForeign $ - \(bytes :: Bytes.Bytes) -> pure $ X.readKeyFileFromMemory $ L.toStrict $ Bytes.toLazyByteString bytes - - declareForeign Tracked "Tls.encodePrivateKey" (argNDirect 1) . mkForeign $ - \(privateKey :: X.PrivKey) -> pure $ Util.Text.toUtf8 $ Util.Text.pack $ show privateKey - - declareForeign Tracked "Tls.receive.impl.v3" argToEF . mkForeignTls $ - \(tls :: TLS.Context) -> do - bs <- TLS.recvData tls - pure $ Bytes.fromArray bs - - declareForeign Tracked "Tls.terminate.impl.v3" argToEF0 . mkForeignTls $ - \(tls :: TLS.Context) -> TLS.bye tls - - declareForeign Untracked "Code.validateLinks" argToExnE - . mkForeign - $ \(lsgs0 :: [(Referent, Code)]) -> do - let f (msg, rs) = - Failure Ty.miscFailureRef (Util.Text.fromText msg) rs - pure . first f $ checkGroupHashes lsgs0 - declareForeign Untracked "Code.dependencies" (argNDirect 1) - . mkForeign - $ \(CodeRep sg _) -> - pure $ Wrap Ty.termLinkRef . Ref <$> groupTermLinks sg - declareForeign Untracked "Code.serialize" (argNDirect 1) - . mkForeign - $ \(co :: Code) -> - pure . Bytes.fromArray $ serializeCode builtinForeignNames co - declareForeign Untracked "Code.deserialize" argToEither - . mkForeign - $ pure . deserializeCode . Bytes.toArray - declareForeign Untracked "Code.display" (argNDirect 2) . mkForeign $ - \(nm, (CodeRep sg _)) -> - pure $ prettyGroup @Symbol (Util.Text.unpack nm) sg "" - declareForeign Untracked "Value.dependencies" (argNDirect 1) - . mkForeign - $ pure . fmap (Wrap Ty.termLinkRef . Ref) . valueTermLinks - declareForeign Untracked "Value.serialize" (argNDirect 1) - . mkForeign - $ pure . Bytes.fromArray . serializeValue - declareForeign Untracked "Value.deserialize" argToEither - . mkForeign - $ pure . deserializeValue . Bytes.toArray + declareForeign Tracked (argNDirect 1) Promise_read + declareForeign Tracked argToMaybe Promise_tryRead + + declareForeign Tracked (argNDirect 2) Promise_write + declareForeign Tracked arg2ToEF Tls_newClient_impl_v3 + declareForeign Tracked arg2ToEF Tls_newServer_impl_v3 + declareForeign Tracked argToEF0 Tls_handshake_impl_v3 + declareForeign Tracked arg2ToEF0 Tls_send_impl_v3 + declareForeign Tracked argToEF Tls_decodeCert_impl_v3 + + declareForeign Tracked (argNDirect 1) Tls_encodeCert + + declareForeign Tracked (argNDirect 1) Tls_decodePrivateKey + declareForeign Tracked (argNDirect 1) Tls_encodePrivateKey + + declareForeign Tracked argToEF Tls_receive_impl_v3 + + declareForeign Tracked argToEF0 Tls_terminate_impl_v3 + declareForeign Untracked argToExnE Code_validateLinks + declareForeign Untracked (argNDirect 1) Code_dependencies + declareForeign Untracked (argNDirect 1) Code_serialize + declareForeign Untracked argToEither Code_deserialize + declareForeign Untracked (argNDirect 2) Code_display + declareForeign Untracked (argNDirect 1) Value_dependencies + declareForeign Untracked (argNDirect 1) Value_serialize + declareForeign Untracked argToEither Value_deserialize -- Hashing functions - let declareHashAlgorithm :: forall alg. (Hash.HashAlgorithm alg) => Data.Text.Text -> alg -> FDecl Symbol () - declareHashAlgorithm txt alg = do - let algoRef = Builtin ("crypto.HashAlgorithm." <> txt) - declareForeign Untracked ("crypto.HashAlgorithm." <> txt) direct . mkForeign $ \() -> - pure (HashAlgorithm algoRef alg) - - declareHashAlgorithm "Sha3_512" Hash.SHA3_512 - declareHashAlgorithm "Sha3_256" Hash.SHA3_256 - declareHashAlgorithm "Sha2_512" Hash.SHA512 - declareHashAlgorithm "Sha2_256" Hash.SHA256 - declareHashAlgorithm "Sha1" Hash.SHA1 - declareHashAlgorithm "Blake2b_512" Hash.Blake2b_512 - declareHashAlgorithm "Blake2b_256" Hash.Blake2b_256 - declareHashAlgorithm "Blake2s_256" Hash.Blake2s_256 - declareHashAlgorithm "Md5" Hash.MD5 - - declareForeign Untracked "crypto.hashBytes" (argNDirect 2) . mkForeign $ - \(HashAlgorithm _ alg, b :: Bytes.Bytes) -> - let ctx = Hash.hashInitWith alg - in pure . Bytes.fromArray . Hash.hashFinalize $ Hash.hashUpdates ctx (Bytes.byteStringChunks b) - - declareForeign Untracked "crypto.hmacBytes" (argNDirect 3) - . mkForeign - $ \(HashAlgorithm _ alg, key :: Bytes.Bytes, msg :: Bytes.Bytes) -> - let out = u alg $ HMAC.hmac (Bytes.toArray @BA.Bytes key) (Bytes.toArray @BA.Bytes msg) - u :: a -> HMAC.HMAC a -> HMAC.HMAC a - u _ h = h -- to help typechecker along - in pure $ Bytes.fromArray out - - declareForeign Untracked "crypto.hash" crypto'hash . mkForeign $ - \(HashAlgorithm _ alg, x) -> - let hashlazy :: - (Hash.HashAlgorithm a) => - a -> - L.ByteString -> - Hash.Digest a - hashlazy _ l = Hash.hashlazy l - in pure . Bytes.fromArray . hashlazy alg $ serializeValueForHash x - - declareForeign Untracked "crypto.hmac" crypto'hmac . mkForeign $ - \(HashAlgorithm _ alg, key, x) -> - let hmac :: - (Hash.HashAlgorithm a) => a -> L.ByteString -> HMAC.HMAC a - hmac _ s = - HMAC.finalize - . HMAC.updates - (HMAC.initialize $ Bytes.toArray @BA.Bytes key) - $ L.toChunks s - in pure . Bytes.fromArray . hmac alg $ serializeValueForHash x - - declareForeign Untracked "crypto.Ed25519.sign.impl" arg3ToEF - . mkForeign - $ pure . signEd25519Wrapper - - declareForeign Untracked "crypto.Ed25519.verify.impl" arg3ToEFBool - . mkForeign - $ pure . verifyEd25519Wrapper - - declareForeign Untracked "crypto.Rsa.sign.impl" arg2ToEF - . mkForeign - $ pure . signRsaWrapper - - declareForeign Untracked "crypto.Rsa.verify.impl" arg3ToEFBool - . mkForeign - $ pure . verifyRsaWrapper - - let catchAll :: (MonadCatch m, MonadIO m, NFData a) => m a -> m (Either Util.Text.Text a) - catchAll e = do - e <- Exception.tryAnyDeep e - pure $ case e of - Left se -> Left (Util.Text.pack (show se)) - Right a -> Right a - - declareForeign Untracked "Universal.murmurHash" murmur'hash . mkForeign $ - pure . asWord64 . hash64 . serializeValueForHash - - declareForeign Tracked "IO.randomBytes" (argNDirect 1) . mkForeign $ - \n -> Bytes.fromArray <$> getRandomBytes @IO @ByteString n - - declareForeign Untracked "Bytes.zlib.compress" (argNDirect 1) . mkForeign $ pure . Bytes.zlibCompress - declareForeign Untracked "Bytes.gzip.compress" (argNDirect 1) . mkForeign $ pure . Bytes.gzipCompress - declareForeign Untracked "Bytes.zlib.decompress" argToEither . mkForeign $ \bs -> - catchAll (pure (Bytes.zlibDecompress bs)) - declareForeign Untracked "Bytes.gzip.decompress" argToEither . mkForeign $ \bs -> - catchAll (pure (Bytes.gzipDecompress bs)) - - declareForeign Untracked "Bytes.toBase16" (argNDirect 1) . mkForeign $ pure . Bytes.toBase16 - declareForeign Untracked "Bytes.toBase32" (argNDirect 1) . mkForeign $ pure . Bytes.toBase32 - declareForeign Untracked "Bytes.toBase64" (argNDirect 1) . mkForeign $ pure . Bytes.toBase64 - declareForeign Untracked "Bytes.toBase64UrlUnpadded" (argNDirect 1) . mkForeign $ pure . Bytes.toBase64UrlUnpadded - - declareForeign Untracked "Bytes.fromBase16" argToEither . mkForeign $ - pure . mapLeft Util.Text.fromText . Bytes.fromBase16 - declareForeign Untracked "Bytes.fromBase32" argToEither . mkForeign $ - pure . mapLeft Util.Text.fromText . Bytes.fromBase32 - declareForeign Untracked "Bytes.fromBase64" argToEither . mkForeign $ - pure . mapLeft Util.Text.fromText . Bytes.fromBase64 - declareForeign Untracked "Bytes.fromBase64UrlUnpadded" argToEither . mkForeign $ - pure . mapLeft Util.Text.fromText . Bytes.fromBase64UrlUnpadded - - declareForeign Untracked "Bytes.decodeNat64be" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat64be - declareForeign Untracked "Bytes.decodeNat64le" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat64le - declareForeign Untracked "Bytes.decodeNat32be" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat32be - declareForeign Untracked "Bytes.decodeNat32le" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat32le - declareForeign Untracked "Bytes.decodeNat16be" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat16be - declareForeign Untracked "Bytes.decodeNat16le" argToMaybeNTup . mkForeign $ pure . Bytes.decodeNat16le - - declareForeign Untracked "Bytes.encodeNat64be" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat64be - declareForeign Untracked "Bytes.encodeNat64le" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat64le - declareForeign Untracked "Bytes.encodeNat32be" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat32be - declareForeign Untracked "Bytes.encodeNat32le" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat32le - declareForeign Untracked "Bytes.encodeNat16be" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat16be - declareForeign Untracked "Bytes.encodeNat16le" (argNDirect 1) . mkForeign $ pure . Bytes.encodeNat16le - - declareForeign Untracked "MutableArray.copyTo!" arg5ToExnUnit - . mkForeign - $ \(dst, doff, src, soff, l) -> - let name = "MutableArray.copyTo!" - in if l == 0 - then pure (Right ()) - else - checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ - checkBounds name (PA.sizeofMutableArray src) (soff + l - 1) $ - Right - <$> PA.copyMutableArray @IO @Val - dst - (fromIntegral doff) - src - (fromIntegral soff) - (fromIntegral l) - - declareForeign Untracked "MutableByteArray.copyTo!" arg5ToExnUnit - . mkForeign - $ \(dst, doff, src, soff, l) -> - let name = "MutableByteArray.copyTo!" - in if l == 0 - then pure (Right ()) - else - checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l) 0 $ - checkBoundsPrim name (PA.sizeofMutableByteArray src) (soff + l) 0 $ - Right - <$> PA.copyMutableByteArray @IO - dst - (fromIntegral doff) - src - (fromIntegral soff) - (fromIntegral l) - - declareForeign Untracked "ImmutableArray.copyTo!" arg5ToExnUnit - . mkForeign - $ \(dst, doff, src, soff, l) -> - let name = "ImmutableArray.copyTo!" - in if l == 0 - then pure (Right ()) - else - checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ - checkBounds name (PA.sizeofArray src) (soff + l - 1) $ - Right - <$> PA.copyArray @IO @Val - dst - (fromIntegral doff) - src - (fromIntegral soff) - (fromIntegral l) - - declareForeign Untracked "ImmutableArray.size" (argNDirect 1) . mkForeign $ - pure . fromIntegral @Int @Word64 . PA.sizeofArray @Val - declareForeign Untracked "MutableArray.size" (argNDirect 1) . mkForeign $ - pure . fromIntegral @Int @Word64 . PA.sizeofMutableArray @PA.RealWorld @Val - declareForeign Untracked "ImmutableByteArray.size" (argNDirect 1) . mkForeign $ - pure . fromIntegral @Int @Word64 . PA.sizeofByteArray - declareForeign Untracked "MutableByteArray.size" (argNDirect 1) . mkForeign $ - pure . fromIntegral @Int @Word64 . PA.sizeofMutableByteArray @PA.RealWorld - - declareForeign Untracked "ImmutableByteArray.copyTo!" arg5ToExnUnit - . mkForeign - $ \(dst, doff, src, soff, l) -> - let name = "ImmutableByteArray.copyTo!" - in if l == 0 - then pure (Right ()) - else - checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l) 0 $ - checkBoundsPrim name (PA.sizeofByteArray src) (soff + l) 0 $ - Right - <$> PA.copyByteArray @IO - dst - (fromIntegral doff) - src - (fromIntegral soff) - (fromIntegral l) - - declareForeign Untracked "MutableArray.read" arg2ToExn - . mkForeign - $ checkedRead "MutableArray.read" - declareForeign Untracked "MutableByteArray.read8" arg2ToExn - . mkForeign - $ checkedRead8 "MutableByteArray.read8" - declareForeign Untracked "MutableByteArray.read16be" arg2ToExn - . mkForeign - $ checkedRead16 "MutableByteArray.read16be" - declareForeign Untracked "MutableByteArray.read24be" arg2ToExn - . mkForeign - $ checkedRead24 "MutableByteArray.read24be" - declareForeign Untracked "MutableByteArray.read32be" arg2ToExn - . mkForeign - $ checkedRead32 "MutableByteArray.read32be" - declareForeign Untracked "MutableByteArray.read40be" arg2ToExn - . mkForeign - $ checkedRead40 "MutableByteArray.read40be" - declareForeign Untracked "MutableByteArray.read64be" arg2ToExn - . mkForeign - $ checkedRead64 "MutableByteArray.read64be" - - declareForeign Untracked "MutableArray.write" arg3ToExnUnit - . mkForeign - $ checkedWrite "MutableArray.write" - declareForeign Untracked "MutableByteArray.write8" arg3ToExnUnit - . mkForeign - $ checkedWrite8 "MutableByteArray.write8" - declareForeign Untracked "MutableByteArray.write16be" arg3ToExnUnit - . mkForeign - $ checkedWrite16 "MutableByteArray.write16be" - declareForeign Untracked "MutableByteArray.write32be" arg3ToExnUnit - . mkForeign - $ checkedWrite32 "MutableByteArray.write32be" - declareForeign Untracked "MutableByteArray.write64be" arg3ToExnUnit - . mkForeign - $ checkedWrite64 "MutableByteArray.write64be" - - declareForeign Untracked "ImmutableArray.read" arg2ToExn - . mkForeign - $ checkedIndex "ImmutableArray.read" - declareForeign Untracked "ImmutableByteArray.read8" arg2ToExn - . mkForeign - $ checkedIndex8 "ImmutableByteArray.read8" - declareForeign Untracked "ImmutableByteArray.read16be" arg2ToExn - . mkForeign - $ checkedIndex16 "ImmutableByteArray.read16be" - declareForeign Untracked "ImmutableByteArray.read24be" arg2ToExn - . mkForeign - $ checkedIndex24 "ImmutableByteArray.read24be" - declareForeign Untracked "ImmutableByteArray.read32be" arg2ToExn - . mkForeign - $ checkedIndex32 "ImmutableByteArray.read32be" - declareForeign Untracked "ImmutableByteArray.read40be" arg2ToExn - . mkForeign - $ checkedIndex40 "ImmutableByteArray.read40be" - declareForeign Untracked "ImmutableByteArray.read64be" arg2ToExn - . mkForeign - $ checkedIndex64 "ImmutableByteArray.read64be" - - declareForeign Untracked "MutableByteArray.freeze!" (argNDirect 1) . mkForeign $ - PA.unsafeFreezeByteArray - declareForeign Untracked "MutableArray.freeze!" (argNDirect 1) . mkForeign $ - PA.unsafeFreezeArray @IO @Val - - declareForeign Untracked "MutableByteArray.freeze" arg3ToExn . mkForeign $ - \(src, off, len) -> - if len == 0 - then fmap Right . PA.unsafeFreezeByteArray =<< PA.newByteArray 0 - else - checkBoundsPrim - "MutableByteArray.freeze" - (PA.sizeofMutableByteArray src) - (off + len) - 0 - $ Right <$> PA.freezeByteArray src (fromIntegral off) (fromIntegral len) - - declareForeign Untracked "MutableArray.freeze" arg3ToExn . mkForeign $ - \(src :: PA.MutableArray PA.RealWorld Val, off, len) -> - if len == 0 - then fmap Right . PA.unsafeFreezeArray =<< PA.newArray 0 emptyVal - else - checkBounds - "MutableArray.freeze" - (PA.sizeofMutableArray src) - (off + len - 1) - $ Right <$> PA.freezeArray src (fromIntegral off) (fromIntegral len) - - declareForeign Untracked "MutableByteArray.length" (argNDirect 1) . mkForeign $ - pure . PA.sizeofMutableByteArray @PA.RealWorld - - declareForeign Untracked "ImmutableByteArray.length" (argNDirect 1) . mkForeign $ - pure . PA.sizeofByteArray - - declareForeign Tracked "IO.array" (argNDirect 1) . mkForeign $ - \n -> PA.newArray n emptyVal - declareForeign Tracked "IO.arrayOf" (argNDirect 2) . mkForeign $ - \(v :: Val, n) -> PA.newArray n v - declareForeign Tracked "IO.bytearray" (argNDirect 1) . mkForeign $ PA.newByteArray - declareForeign Tracked "IO.bytearrayOf" (argNDirect 2) - . mkForeign - $ \(init, sz) -> do - arr <- PA.newByteArray sz - PA.fillByteArray arr 0 sz init - pure arr - - declareForeign Untracked "Scope.array" (argNDirect 1) . mkForeign $ - \n -> PA.newArray n emptyVal - declareForeign Untracked "Scope.arrayOf" (argNDirect 2) . mkForeign $ - \(v :: Val, n) -> PA.newArray n v - declareForeign Untracked "Scope.bytearray" (argNDirect 1) . mkForeign $ PA.newByteArray - declareForeign Untracked "Scope.bytearrayOf" (argNDirect 2) - . mkForeign - $ \(init, sz) -> do - arr <- PA.newByteArray sz - PA.fillByteArray arr 0 sz init - pure arr - - declareForeign Untracked "Text.patterns.literal" (argNDirect 1) . mkForeign $ - \txt -> evaluate . TPat.cpattern $ TPat.Literal txt - declareForeign Untracked "Text.patterns.digit" direct . mkForeign $ - let v = TPat.cpattern (TPat.Char (TPat.CharRange '0' '9')) in \() -> pure v - declareForeign Untracked "Text.patterns.letter" direct . mkForeign $ - let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Letter)) in \() -> pure v - declareForeign Untracked "Text.patterns.space" direct . mkForeign $ - let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Whitespace)) in \() -> pure v - declareForeign Untracked "Text.patterns.punctuation" direct . mkForeign $ - let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Punctuation)) in \() -> pure v - declareForeign Untracked "Text.patterns.anyChar" direct . mkForeign $ - let v = TPat.cpattern (TPat.Char TPat.Any) in \() -> pure v - declareForeign Untracked "Text.patterns.eof" direct . mkForeign $ - let v = TPat.cpattern TPat.Eof in \() -> pure v - declareForeign Untracked "Text.patterns.charRange" (argNDirect 2) . mkForeign $ - \(beg, end) -> evaluate . TPat.cpattern . TPat.Char $ TPat.CharRange beg end - declareForeign Untracked "Text.patterns.notCharRange" (argNDirect 2) . mkForeign $ - \(beg, end) -> evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharRange beg end - declareForeign Untracked "Text.patterns.charIn" (argNDirect 1) . mkForeign $ \ccs -> do - cs <- for ccs $ \case - CharVal c -> pure c - _ -> die "Text.patterns.charIn: non-character closure" - evaluate . TPat.cpattern . TPat.Char $ TPat.CharSet cs - declareForeign Untracked "Text.patterns.notCharIn" (argNDirect 1) . mkForeign $ \ccs -> do - cs <- for ccs $ \case - CharVal c -> pure c - _ -> die "Text.patterns.notCharIn: non-character closure" - evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharSet cs - declareForeign Untracked "Pattern.many" (argNDirect 1) . mkForeign $ - \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many False p - declareForeign Untracked "Pattern.many.corrected" (argNDirect 1) . mkForeign $ - \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many True p - declareForeign Untracked "Pattern.capture" (argNDirect 1) . mkForeign $ - \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Capture p - declareForeign Untracked "Pattern.captureAs" (argNDirect 2) . mkForeign $ - \(t, (TPat.CP p _)) -> evaluate . TPat.cpattern $ TPat.CaptureAs t p - declareForeign Untracked "Pattern.join" (argNDirect 1) . mkForeign $ \ps -> - evaluate . TPat.cpattern . TPat.Join $ map (\(TPat.CP p _) -> p) ps - declareForeign Untracked "Pattern.or" (argNDirect 2) . mkForeign $ - \(TPat.CP l _, TPat.CP r _) -> evaluate . TPat.cpattern $ TPat.Or l r - declareForeign Untracked "Pattern.replicate" (argNDirect 3) . mkForeign $ - \(m0 :: Word64, n0 :: Word64, TPat.CP p _) -> - let m = fromIntegral m0; n = fromIntegral n0 - in evaluate . TPat.cpattern $ TPat.Replicate m n p - - declareForeign Untracked "Pattern.run" arg2ToMaybeTup . mkForeign $ - \(TPat.CP _ matcher, input :: Text) -> pure $ matcher input - - declareForeign Untracked "Pattern.isMatch" (argNDirect 2) . mkForeign $ - \(TPat.CP _ matcher, input :: Text) -> pure . isJust $ matcher input - - declareForeign Untracked "Char.Class.any" direct . mkForeign $ \() -> pure TPat.Any - declareForeign Untracked "Char.Class.not" (argNDirect 1) . mkForeign $ pure . TPat.Not - declareForeign Untracked "Char.Class.and" (argNDirect 2) . mkForeign $ \(a, b) -> pure $ TPat.Intersect a b - declareForeign Untracked "Char.Class.or" (argNDirect 2) . mkForeign $ \(a, b) -> pure $ TPat.Union a b - declareForeign Untracked "Char.Class.range" (argNDirect 2) . mkForeign $ \(a, b) -> pure $ TPat.CharRange a b - declareForeign Untracked "Char.Class.anyOf" (argNDirect 1) . mkForeign $ \ccs -> do - cs <- for ccs $ \case - CharVal c -> pure c - _ -> die "Text.patterns.charIn: non-character closure" - evaluate $ TPat.CharSet cs - declareForeign Untracked "Char.Class.alphanumeric" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.AlphaNum) - declareForeign Untracked "Char.Class.upper" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Upper) - declareForeign Untracked "Char.Class.lower" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Lower) - declareForeign Untracked "Char.Class.whitespace" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Whitespace) - declareForeign Untracked "Char.Class.control" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Control) - declareForeign Untracked "Char.Class.printable" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Printable) - declareForeign Untracked "Char.Class.mark" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.MarkChar) - declareForeign Untracked "Char.Class.number" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Number) - declareForeign Untracked "Char.Class.punctuation" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Punctuation) - declareForeign Untracked "Char.Class.symbol" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Symbol) - declareForeign Untracked "Char.Class.separator" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Separator) - declareForeign Untracked "Char.Class.letter" direct . mkForeign $ \() -> pure (TPat.CharClass TPat.Letter) - declareForeign Untracked "Char.Class.is" (argNDirect 2) . mkForeign $ \(cl, c) -> evaluate $ TPat.charPatternPred cl c - declareForeign Untracked "Text.patterns.char" (argNDirect 1) . mkForeign $ \c -> - let v = TPat.cpattern (TPat.Char c) in pure v - -type RW = PA.PrimState IO - -checkedRead :: - Text -> (PA.MutableArray RW Val, Word64) -> IO (Either Failure Val) -checkedRead name (arr, w) = - checkBounds - name - (PA.sizeofMutableArray arr) - w - (Right <$> PA.readArray arr (fromIntegral w)) - -checkedWrite :: - Text -> (PA.MutableArray RW Val, Word64, Val) -> IO (Either Failure ()) -checkedWrite name (arr, w, v) = - checkBounds - name - (PA.sizeofMutableArray arr) - w - (Right <$> PA.writeArray arr (fromIntegral w) v) - -checkedIndex :: - Text -> (PA.Array Val, Word64) -> IO (Either Failure Val) -checkedIndex name (arr, w) = - checkBounds - name - (PA.sizeofArray arr) - w - (Right <$> PA.indexArrayM arr (fromIntegral w)) - -checkedRead8 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead8 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 1 $ - (Right . fromIntegral) <$> PA.readByteArray @Word8 arr j - where - j = fromIntegral i - -checkedRead16 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead16 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 2 $ - mk16 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - where - j = fromIntegral i - -checkedRead24 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead24 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 3 $ - mk24 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - <*> PA.readByteArray @Word8 arr (j + 2) - where - j = fromIntegral i - -checkedRead32 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead32 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 4 $ - mk32 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - <*> PA.readByteArray @Word8 arr (j + 2) - <*> PA.readByteArray @Word8 arr (j + 3) - where - j = fromIntegral i - -checkedRead40 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead40 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 6 $ - mk40 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - <*> PA.readByteArray @Word8 arr (j + 2) - <*> PA.readByteArray @Word8 arr (j + 3) - <*> PA.readByteArray @Word8 arr (j + 4) - where - j = fromIntegral i - -checkedRead64 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) -checkedRead64 name (arr, i) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 8 $ - mk64 - <$> PA.readByteArray @Word8 arr j - <*> PA.readByteArray @Word8 arr (j + 1) - <*> PA.readByteArray @Word8 arr (j + 2) - <*> PA.readByteArray @Word8 arr (j + 3) - <*> PA.readByteArray @Word8 arr (j + 4) - <*> PA.readByteArray @Word8 arr (j + 5) - <*> PA.readByteArray @Word8 arr (j + 6) - <*> PA.readByteArray @Word8 arr (j + 7) - where - j = fromIntegral i - -mk16 :: Word8 -> Word8 -> Either Failure Word64 -mk16 b0 b1 = Right $ (fromIntegral b0 `shiftL` 8) .|. (fromIntegral b1) - -mk24 :: Word8 -> Word8 -> Word8 -> Either Failure Word64 -mk24 b0 b1 b2 = - Right $ - (fromIntegral b0 `shiftL` 16) - .|. (fromIntegral b1 `shiftL` 8) - .|. (fromIntegral b2) - -mk32 :: Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 -mk32 b0 b1 b2 b3 = - Right $ - (fromIntegral b0 `shiftL` 24) - .|. (fromIntegral b1 `shiftL` 16) - .|. (fromIntegral b2 `shiftL` 8) - .|. (fromIntegral b3) - -mk40 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 -mk40 b0 b1 b2 b3 b4 = - Right $ - (fromIntegral b0 `shiftL` 32) - .|. (fromIntegral b1 `shiftL` 24) - .|. (fromIntegral b2 `shiftL` 16) - .|. (fromIntegral b3 `shiftL` 8) - .|. (fromIntegral b4) - -mk64 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 -mk64 b0 b1 b2 b3 b4 b5 b6 b7 = - Right $ - (fromIntegral b0 `shiftL` 56) - .|. (fromIntegral b1 `shiftL` 48) - .|. (fromIntegral b2 `shiftL` 40) - .|. (fromIntegral b3 `shiftL` 32) - .|. (fromIntegral b4 `shiftL` 24) - .|. (fromIntegral b5 `shiftL` 16) - .|. (fromIntegral b6 `shiftL` 8) - .|. (fromIntegral b7) - -checkedWrite8 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) -checkedWrite8 name (arr, i, v) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 1 $ do - PA.writeByteArray arr j (fromIntegral v :: Word8) - pure (Right ()) - where - j = fromIntegral i - -checkedWrite16 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) -checkedWrite16 name (arr, i, v) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 2 $ do - PA.writeByteArray arr j (fromIntegral $ v `shiftR` 8 :: Word8) - PA.writeByteArray arr (j + 1) (fromIntegral v :: Word8) - pure (Right ()) - where - j = fromIntegral i - -checkedWrite32 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) -checkedWrite32 name (arr, i, v) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 4 $ do - PA.writeByteArray arr j (fromIntegral $ v `shiftR` 24 :: Word8) - PA.writeByteArray arr (j + 1) (fromIntegral $ v `shiftR` 16 :: Word8) - PA.writeByteArray arr (j + 2) (fromIntegral $ v `shiftR` 8 :: Word8) - PA.writeByteArray arr (j + 3) (fromIntegral v :: Word8) - pure (Right ()) - where - j = fromIntegral i - -checkedWrite64 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) -checkedWrite64 name (arr, i, v) = - checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 8 $ do - PA.writeByteArray arr j (fromIntegral $ v `shiftR` 56 :: Word8) - PA.writeByteArray arr (j + 1) (fromIntegral $ v `shiftR` 48 :: Word8) - PA.writeByteArray arr (j + 2) (fromIntegral $ v `shiftR` 40 :: Word8) - PA.writeByteArray arr (j + 3) (fromIntegral $ v `shiftR` 32 :: Word8) - PA.writeByteArray arr (j + 4) (fromIntegral $ v `shiftR` 24 :: Word8) - PA.writeByteArray arr (j + 5) (fromIntegral $ v `shiftR` 16 :: Word8) - PA.writeByteArray arr (j + 6) (fromIntegral $ v `shiftR` 8 :: Word8) - PA.writeByteArray arr (j + 7) (fromIntegral v :: Word8) - pure (Right ()) - where - j = fromIntegral i - --- index single byte -checkedIndex8 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex8 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 1 . pure $ - let j = fromIntegral i - in Right . fromIntegral $ PA.indexByteArray @Word8 arr j - --- index 16 big-endian -checkedIndex16 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex16 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 2 . pure $ - let j = fromIntegral i - in mk16 (PA.indexByteArray arr j) (PA.indexByteArray arr (j + 1)) - --- index 32 big-endian -checkedIndex24 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex24 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 3 . pure $ - let j = fromIntegral i - in mk24 - (PA.indexByteArray arr j) - (PA.indexByteArray arr (j + 1)) - (PA.indexByteArray arr (j + 2)) - --- index 32 big-endian -checkedIndex32 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex32 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 4 . pure $ - let j = fromIntegral i - in mk32 - (PA.indexByteArray arr j) - (PA.indexByteArray arr (j + 1)) - (PA.indexByteArray arr (j + 2)) - (PA.indexByteArray arr (j + 3)) - --- index 40 big-endian -checkedIndex40 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex40 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 5 . pure $ - let j = fromIntegral i - in mk40 - (PA.indexByteArray arr j) - (PA.indexByteArray arr (j + 1)) - (PA.indexByteArray arr (j + 2)) - (PA.indexByteArray arr (j + 3)) - (PA.indexByteArray arr (j + 4)) - --- index 64 big-endian -checkedIndex64 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) -checkedIndex64 name (arr, i) = - checkBoundsPrim name (PA.sizeofByteArray arr) i 8 . pure $ - let j = fromIntegral i - in mk64 - (PA.indexByteArray arr j) - (PA.indexByteArray arr (j + 1)) - (PA.indexByteArray arr (j + 2)) - (PA.indexByteArray arr (j + 3)) - (PA.indexByteArray arr (j + 4)) - (PA.indexByteArray arr (j + 5)) - (PA.indexByteArray arr (j + 6)) - (PA.indexByteArray arr (j + 7)) - -checkBounds :: Text -> Int -> Word64 -> IO (Either Failure b) -> IO (Either Failure b) -checkBounds name l w act - | w < fromIntegral l = act - | otherwise = pure $ Left err - where - msg = name <> ": array index out of bounds" - err = Failure Ty.arrayFailureRef msg (natValue w) - --- Performs a bounds check on a byte array. Strategy is as follows: --- --- isz = signed array size-in-bytes --- off = unsigned byte offset into the array --- esz = unsigned number of bytes to be read --- --- 1. Turn the signed size-in-bytes of the array unsigned --- 2. Add the offset to the to-be-read number to get the maximum size needed --- 3. Check that the actual array size is at least as big as the needed size --- 4. Check that the offset is less than the size --- --- Step 4 ensures that step 3 has not overflowed. Since an actual array size can --- only be 63 bits (since it is signed), the only way for 3 to overflow is if --- the offset is larger than a possible array size, since it would need to be --- 2^64-k, where k is the small (<=8) number of bytes to be read. -checkBoundsPrim :: - Text -> Int -> Word64 -> Word64 -> IO (Either Failure b) -> IO (Either Failure b) -checkBoundsPrim name isz off esz act - | w > bsz || off > bsz = pure $ Left err - | otherwise = act - where - msg = name <> ": array index out of bounds" - err = Failure Ty.arrayFailureRef msg (natValue off) - - bsz = fromIntegral isz - w = off + esz - -hostPreference :: Maybe Util.Text.Text -> SYS.HostPreference -hostPreference Nothing = SYS.HostAny -hostPreference (Just host) = SYS.Host $ Util.Text.unpack host - -signEd25519Wrapper :: - (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes -signEd25519Wrapper (secret0, public0, msg0) = case validated of - CryptoFailed err -> - Left (Failure Ty.cryptoFailureRef (errMsg err) unitValue) - CryptoPassed (secret, public) -> - Right . Bytes.fromArray $ Ed25519.sign secret public msg - where - msg = Bytes.toArray msg0 :: ByteString - validated = - (,) - <$> Ed25519.secretKey (Bytes.toArray secret0 :: ByteString) - <*> Ed25519.publicKey (Bytes.toArray public0 :: ByteString) - - errMsg CryptoError_PublicKeySizeInvalid = - "ed25519: Public key size invalid" - errMsg CryptoError_SecretKeySizeInvalid = - "ed25519: Secret key size invalid" - errMsg CryptoError_SecretKeyStructureInvalid = - "ed25519: Secret key structure invalid" - errMsg _ = "ed25519: unexpected error" - -verifyEd25519Wrapper :: - (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bool -verifyEd25519Wrapper (public0, msg0, sig0) = case validated of - CryptoFailed err -> - Left $ Failure Ty.cryptoFailureRef (errMsg err) unitValue - CryptoPassed (public, sig) -> - Right $ Ed25519.verify public msg sig - where - msg = Bytes.toArray msg0 :: ByteString - validated = - (,) - <$> Ed25519.publicKey (Bytes.toArray public0 :: ByteString) - <*> Ed25519.signature (Bytes.toArray sig0 :: ByteString) - - errMsg CryptoError_PublicKeySizeInvalid = - "ed25519: Public key size invalid" - errMsg CryptoError_SecretKeySizeInvalid = - "ed25519: Secret key size invalid" - errMsg CryptoError_SecretKeyStructureInvalid = - "ed25519: Secret key structure invalid" - errMsg _ = "ed25519: unexpected error" - -signRsaWrapper :: - (Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes -signRsaWrapper (secret0, msg0) = case validated of - Left err -> - Left (Failure Ty.cryptoFailureRef err unitValue) - Right secret -> - case RSA.sign Nothing (Just Hash.SHA256) secret msg of - Left err -> Left (Failure Ty.cryptoFailureRef (Rsa.rsaErrorToText err) unitValue) - Right signature -> Right $ Bytes.fromByteString signature - where - msg = Bytes.toArray msg0 :: ByteString - validated = Rsa.parseRsaPrivateKey (Bytes.toArray secret0 :: ByteString) - -verifyRsaWrapper :: - (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bool -verifyRsaWrapper (public0, msg0, sig0) = case validated of - Left err -> - Left $ Failure Ty.cryptoFailureRef err unitValue - Right public -> - Right $ RSA.verify (Just Hash.SHA256) public msg sig - where - msg = Bytes.toArray msg0 :: ByteString - sig = Bytes.toArray sig0 :: ByteString - validated = Rsa.parseRsaPublicKey (Bytes.toArray public0 :: ByteString) - -foreignDeclResults :: - Bool -> (Word64, [(Data.Text.Text, (Sandbox, SuperNormal Symbol))], EnumMap Word64 (Data.Text.Text, ForeignFunc)) -foreignDeclResults sanitize = - execState (runReaderT declareForeigns sanitize) (0, [], mempty) + declareForeign Untracked direct Crypto_HashAlgorithm_Sha3_512 + declareForeign Untracked direct Crypto_HashAlgorithm_Sha3_256 + declareForeign Untracked direct Crypto_HashAlgorithm_Sha2_512 + declareForeign Untracked direct Crypto_HashAlgorithm_Sha2_256 + declareForeign Untracked direct Crypto_HashAlgorithm_Sha1 + declareForeign Untracked direct Crypto_HashAlgorithm_Blake2b_512 + declareForeign Untracked direct Crypto_HashAlgorithm_Blake2b_256 + declareForeign Untracked direct Crypto_HashAlgorithm_Blake2s_256 + declareForeign Untracked direct Crypto_HashAlgorithm_Md5 + + declareForeign Untracked (argNDirect 2) Crypto_hashBytes + declareForeign Untracked (argNDirect 3) Crypto_hmacBytes + + declareForeign Untracked crypto'hash Crypto_hash + declareForeign Untracked crypto'hmac Crypto_hmac + declareForeign Untracked arg3ToEF Crypto_Ed25519_sign_impl + + declareForeign Untracked arg3ToEFBool Crypto_Ed25519_verify_impl + + declareForeign Untracked arg2ToEF Crypto_Rsa_sign_impl + + declareForeign Untracked arg3ToEFBool Crypto_Rsa_verify_impl + + declareForeign Untracked murmur'hash Universal_murmurHash + declareForeign Tracked (argNDirect 1) IO_randomBytes + declareForeign Untracked (argNDirect 1) Bytes_zlib_compress + declareForeign Untracked (argNDirect 1) Bytes_gzip_compress + declareForeign Untracked argToEither Bytes_zlib_decompress + declareForeign Untracked argToEither Bytes_gzip_decompress + + declareForeign Untracked (argNDirect 1) Bytes_toBase16 + declareForeign Untracked (argNDirect 1) Bytes_toBase32 + declareForeign Untracked (argNDirect 1) Bytes_toBase64 + declareForeign Untracked (argNDirect 1) Bytes_toBase64UrlUnpadded + + declareForeign Untracked argToEither Bytes_fromBase16 + declareForeign Untracked argToEither Bytes_fromBase32 + declareForeign Untracked argToEither Bytes_fromBase64 + declareForeign Untracked argToEither Bytes_fromBase64UrlUnpadded + + declareForeign Untracked argToMaybeNTup Bytes_decodeNat64be + declareForeign Untracked argToMaybeNTup Bytes_decodeNat64le + declareForeign Untracked argToMaybeNTup Bytes_decodeNat32be + declareForeign Untracked argToMaybeNTup Bytes_decodeNat32le + declareForeign Untracked argToMaybeNTup Bytes_decodeNat16be + declareForeign Untracked argToMaybeNTup Bytes_decodeNat16le + + declareForeign Untracked (argNDirect 1) Bytes_encodeNat64be + declareForeign Untracked (argNDirect 1) Bytes_encodeNat64le + declareForeign Untracked (argNDirect 1) Bytes_encodeNat32be + declareForeign Untracked (argNDirect 1) Bytes_encodeNat32le + declareForeign Untracked (argNDirect 1) Bytes_encodeNat16be + declareForeign Untracked (argNDirect 1) Bytes_encodeNat16le + + declareForeign Untracked arg5ToExnUnit MutableArray_copyTo_force + + declareForeign Untracked arg5ToExnUnit MutableByteArray_copyTo_force + + declareForeign Untracked arg5ToExnUnit ImmutableArray_copyTo_force + + declareForeign Untracked (argNDirect 1) ImmutableArray_size + declareForeign Untracked (argNDirect 1) MutableArray_size + declareForeign Untracked (argNDirect 1) ImmutableByteArray_size + declareForeign Untracked (argNDirect 1) MutableByteArray_size + + declareForeign Untracked arg5ToExnUnit ImmutableByteArray_copyTo_force + + declareForeign Untracked arg2ToExn MutableArray_read + declareForeign Untracked arg2ToExn MutableByteArray_read8 + declareForeign Untracked arg2ToExn MutableByteArray_read16be + declareForeign Untracked arg2ToExn MutableByteArray_read24be + declareForeign Untracked arg2ToExn MutableByteArray_read32be + declareForeign Untracked arg2ToExn MutableByteArray_read40be + declareForeign Untracked arg2ToExn MutableByteArray_read64be + + declareForeign Untracked arg3ToExnUnit MutableArray_write + declareForeign Untracked arg3ToExnUnit MutableByteArray_write8 + declareForeign Untracked arg3ToExnUnit MutableByteArray_write16be + declareForeign Untracked arg3ToExnUnit MutableByteArray_write32be + declareForeign Untracked arg3ToExnUnit MutableByteArray_write64be + + declareForeign Untracked arg2ToExn ImmutableArray_read + declareForeign Untracked arg2ToExn ImmutableByteArray_read8 + declareForeign Untracked arg2ToExn ImmutableByteArray_read16be + declareForeign Untracked arg2ToExn ImmutableByteArray_read24be + declareForeign Untracked arg2ToExn ImmutableByteArray_read32be + declareForeign Untracked arg2ToExn ImmutableByteArray_read40be + declareForeign Untracked arg2ToExn ImmutableByteArray_read64be + + declareForeign Untracked (argNDirect 1) MutableByteArray_freeze_force + declareForeign Untracked (argNDirect 1) MutableArray_freeze_force + + declareForeign Untracked arg3ToExn MutableByteArray_freeze + declareForeign Untracked arg3ToExn MutableArray_freeze + + declareForeign Untracked (argNDirect 1) MutableByteArray_length + + declareForeign Untracked (argNDirect 1) ImmutableByteArray_length + + declareForeign Tracked (argNDirect 1) IO_array + declareForeign Tracked (argNDirect 2) IO_arrayOf + declareForeign Tracked (argNDirect 1) IO_bytearray + declareForeign Tracked (argNDirect 2) IO_bytearrayOf + + declareForeign Untracked (argNDirect 1) Scope_array + declareForeign Untracked (argNDirect 2) Scope_arrayOf + declareForeign Untracked (argNDirect 1) Scope_bytearray + declareForeign Untracked (argNDirect 2) Scope_bytearrayOf + + declareForeign Untracked (argNDirect 1) Text_patterns_literal + declareForeign Untracked direct Text_patterns_digit + declareForeign Untracked direct Text_patterns_letter + declareForeign Untracked direct Text_patterns_space + declareForeign Untracked direct Text_patterns_punctuation + declareForeign Untracked direct Text_patterns_anyChar + declareForeign Untracked direct Text_patterns_eof + declareForeign Untracked (argNDirect 2) Text_patterns_charRange + declareForeign Untracked (argNDirect 2) Text_patterns_notCharRange + declareForeign Untracked (argNDirect 1) Text_patterns_charIn + declareForeign Untracked (argNDirect 1) Text_patterns_notCharIn + declareForeign Untracked (argNDirect 1) Pattern_many + declareForeign Untracked (argNDirect 1) Pattern_many_corrected + declareForeign Untracked (argNDirect 1) Pattern_capture + declareForeign Untracked (argNDirect 2) Pattern_captureAs + declareForeign Untracked (argNDirect 1) Pattern_join + declareForeign Untracked (argNDirect 2) Pattern_or + declareForeign Untracked (argNDirect 3) Pattern_replicate + + declareForeign Untracked arg2ToMaybeTup Pattern_run + + declareForeign Untracked (argNDirect 2) Pattern_isMatch + + declareForeign Untracked direct Char_Class_any + declareForeign Untracked (argNDirect 1) Char_Class_not + declareForeign Untracked (argNDirect 2) Char_Class_and + declareForeign Untracked (argNDirect 2) Char_Class_or + declareForeign Untracked (argNDirect 2) Char_Class_range + declareForeign Untracked (argNDirect 1) Char_Class_anyOf + declareForeign Untracked direct Char_Class_alphanumeric + declareForeign Untracked direct Char_Class_upper + declareForeign Untracked direct Char_Class_lower + declareForeign Untracked direct Char_Class_whitespace + declareForeign Untracked direct Char_Class_control + declareForeign Untracked direct Char_Class_printable + declareForeign Untracked direct Char_Class_mark + declareForeign Untracked direct Char_Class_number + declareForeign Untracked direct Char_Class_punctuation + declareForeign Untracked direct Char_Class_symbol + declareForeign Untracked direct Char_Class_separator + declareForeign Untracked direct Char_Class_letter + declareForeign Untracked (argNDirect 2) Char_Class_is + declareForeign Untracked (argNDirect 1) Text_patterns_char + +foreignDeclResults :: (Map ForeignFunc (Sandbox, SuperNormal Symbol)) +foreignDeclResults = + execState declareForeigns mempty foreignWrappers :: [(Data.Text.Text, (Sandbox, SuperNormal Symbol))] -foreignWrappers | (_, l, _) <- foreignDeclResults False = reverse l +foreignWrappers = + Map.toList foreignDeclResults + <&> \(ff, (sand, code)) -> (foreignFuncBuiltinName ff, (sand, code)) numberedTermLookup :: EnumMap Word64 (SuperNormal Symbol) numberedTermLookup = @@ -3169,14 +2100,12 @@ builtinTermBackref :: EnumMap Word64 Reference builtinTermBackref = mapFromList . zip [1 ..] . Map.keys $ builtinLookup -builtinForeigns :: EnumMap Word64 ForeignFunc -builtinForeigns | (_, _, m) <- foreignDeclResults False = snd <$> m - -sandboxedForeigns :: EnumMap Word64 ForeignFunc -sandboxedForeigns | (_, _, m) <- foreignDeclResults True = snd <$> m - -builtinForeignNames :: EnumMap Word64 Data.Text.Text -builtinForeignNames | (_, _, m) <- foreignDeclResults False = fst <$> m +builtinForeignNames :: Map ForeignFunc Data.Text.Text +builtinForeignNames = + foreignDeclResults + & Map.keys + & map (\f -> (f, foreignFuncBuiltinName f)) + & Map.fromList -- Bootstrapping for sandbox check. The eventual map will be one with -- associations `r -> s` where `s` is all the 'sensitive' base @@ -3198,5 +2127,7 @@ builtinInlineInfo :: Map Reference (Int, ANormal Symbol) builtinInlineInfo = ANF.buildInlineMap $ fmap (Rec [] . snd) builtinLookup -unsafeSTMToIO :: STM.STM a -> IO a -unsafeSTMToIO (STM.STM m) = IO m +sandboxedForeignFuncs :: Set ForeignFunc +sandboxedForeignFuncs = + Map.keysSet $ + Map.filter (\(sb, _) -> sb == Tracked) foreignDeclResults diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index 71808e9ab3..f4404ccfb7 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -1,42 +1,156 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -module Unison.Runtime.Foreign.Function - ( ForeignFunc (..), - ForeignConvention (..), - mkForeign, - ) -where +module Unison.Runtime.Foreign.Function (foreignCall) where import Control.Concurrent (ThreadId) -import Control.Concurrent.MVar (MVar) +import Control.Concurrent as SYS + ( killThread, + threadDelay, + ) +import Control.Concurrent.MVar as SYS import Control.Concurrent.STM (TVar) -import Control.Exception (evaluate) +import Control.Concurrent.STM qualified as STM +import Control.DeepSeq (NFData) +import Control.Exception +import Control.Exception.Safe qualified as Exception +import Control.Monad.Catch (MonadCatch) +import Control.Monad.Primitive qualified as PA +import Crypto.Error (CryptoError (..), CryptoFailable (..)) +import Crypto.Hash qualified as Hash +import Crypto.MAC.HMAC qualified as HMAC +import Crypto.PubKey.Ed25519 qualified as Ed25519 +import Crypto.PubKey.RSA.PKCS15 qualified as RSA +import Crypto.Random (getRandomBytes) import Data.Atomics (Ticket) -import Data.Foldable (toList) +import Data.Bits (shiftL, shiftR, (.|.)) +import Data.ByteArray qualified as BA +import Data.ByteString (hGet, hGetSome, hPut) +import Data.ByteString.Lazy qualified as L +import Data.Default (def) +import Data.Digest.Murmur64 (asWord64, hash64) import Data.IORef (IORef) +import Data.IP (IP) +import Data.PEM (PEM, pemContent, pemParseLBS) import Data.Sequence qualified as Sq +import Data.Text qualified +import Data.Text.IO qualified as Text.IO import Data.Time.Clock.POSIX (POSIXTime) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Base (IO (..)) +import Data.Time.Clock.POSIX as SYS + ( getPOSIXTime, + posixSecondsToUTCTime, + utcTimeToPOSIXSeconds, + ) +import Data.Time.LocalTime (TimeZone (..), getTimeZone) +import Data.X509 qualified as X +import Data.X509.CertificateStore qualified as X +import Data.X509.Memory qualified as X +import GHC.Conc qualified as STM +import GHC.IO (IO (IO)) import GHC.IO.Exception (IOErrorType (..), IOException (..)) +import Network.Simple.TCP as SYS + ( HostPreference (..), + bindSock, + closeSock, + connectSock, + listenSock, + recv, + send, + ) import Network.Socket (Socket) +import Network.Socket as SYS + ( PortNumber, + Socket, + accept, + socketPort, + ) +import Network.TLS as TLS +import Network.TLS.Extra.Cipher as Cipher import Network.UDP (UDPSocket) +import Network.UDP as UDP + ( ClientSockAddr, + ListenSocket, + clientSocket, + close, + recv, + recvFrom, + send, + sendTo, + serverSocket, + stop, + ) +import System.Clock (Clock (..), getTime, nsec, sec) +import System.Directory as SYS + ( createDirectoryIfMissing, + doesDirectoryExist, + doesPathExist, + getCurrentDirectory, + getDirectoryContents, + getFileSize, + getModificationTime, + getTemporaryDirectory, + removeDirectoryRecursive, + removeFile, + renameDirectory, + renameFile, + setCurrentDirectory, + ) +import System.Environment as SYS + ( getArgs, + getEnv, + ) +import System.Exit as SYS (ExitCode (..)) +import System.FilePath (isPathSeparator) import System.IO (BufferMode (..), Handle, IOMode, SeekMode) +import System.IO as SYS + ( IOMode (..), + hClose, + hGetBuffering, + hGetChar, + hGetEcho, + hIsEOF, + hIsOpen, + hIsSeekable, + hReady, + hSeek, + hSetBuffering, + hSetEcho, + hTell, + openFile, + stderr, + stdin, + stdout, + ) +import System.IO.Temp (createTempDirectory) +import System.Process as SYS + ( getProcessExitCode, + proc, + runInteractiveProcess, + terminateProcess, + waitForProcess, + withCreateProcess, + ) +import System.X509 qualified as X import Unison.Builtin.Decls qualified as Ty -import Unison.Reference (Reference) +import Unison.Prelude hiding (Text, some) +import Unison.Reference +import Unison.Referent (Referent, pattern Ref) import Unison.Runtime.ANF (Code, PackedTag (..), Value, internalBug) +import Unison.Runtime.ANF qualified as ANF +import Unison.Runtime.ANF.Rehash (checkGroupHashes) +import Unison.Runtime.ANF.Serialize qualified as ANF import Unison.Runtime.Array qualified as PA +import Unison.Runtime.Builtin +import Unison.Runtime.Crypto.Rsa qualified as Rsa import Unison.Runtime.Exception -import Unison.Runtime.Foreign +import Unison.Runtime.Foreign hiding (Failure) +import Unison.Runtime.Foreign qualified as F +import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..)) import Unison.Runtime.MCode import Unison.Runtime.Stack +import Unison.Symbol import Unison.Type ( iarrayRef, ibytearrayRef, @@ -49,26 +163,1158 @@ import Unison.Type tvarRef, typeLinkRef, ) +import Unison.Type qualified as Ty import Unison.Util.Bytes (Bytes) -import Unison.Util.RefPromise (Promise) +import Unison.Util.Bytes qualified as Bytes +import Unison.Util.RefPromise + ( Promise, + newPromise, + readPromise, + tryReadPromise, + writePromise, + ) import Unison.Util.Text (Text, pack, unpack) +import Unison.Util.Text qualified as Util.Text +import Unison.Util.Text.Pattern qualified as TPat +import UnliftIO qualified + +-- foreignCall is explicitly NOINLINE'd because it's a _huge_ chunk of code and negatively affects code caching. +-- Because we're not inlining it, we need a wrapper using an explicitly unboxed Stack so we don't block the +-- worker-wrapper optimizations in the main eval loop. +-- It looks dump to accept an unboxed stack and then immediately box it up, but GHC is sufficiently smart to +-- unbox all of 'foreignCallHelper' when we write it this way, but it's way less work to use the regular lifted stack +-- in its implementation. +{-# NOINLINE foreignCall #-} +foreignCall :: ForeignFunc -> Args -> XStack -> IOXStack +foreignCall !ff !args !xstk = + stackIOToIOX $ foreignCallHelper ff args (packXStack xstk) + +{-# INLINE foreignCallHelper #-} +foreignCallHelper :: ForeignFunc -> Args -> Stack -> IO Stack +foreignCallHelper = \case + IO_UDP_clientSocket_impl_v1 -> mkForeignIOF $ \(host :: Util.Text.Text, port :: Util.Text.Text) -> + let hostStr = Util.Text.toString host + portStr = Util.Text.toString port + in UDP.clientSocket hostStr portStr True + IO_UDP_UDPSocket_recv_impl_v1 -> mkForeignIOF $ \(sock :: UDPSocket) -> Bytes.fromArray <$> UDP.recv sock + IO_UDP_UDPSocket_send_impl_v1 -> mkForeignIOF $ + \(sock :: UDPSocket, bytes :: Bytes.Bytes) -> + UDP.send sock (Bytes.toArray bytes) + IO_UDP_UDPSocket_close_impl_v1 -> mkForeignIOF $ + \(sock :: UDPSocket) -> UDP.close sock + IO_UDP_ListenSocket_close_impl_v1 -> mkForeignIOF $ + \(sock :: ListenSocket) -> UDP.stop sock + IO_UDP_UDPSocket_toText_impl_v1 -> mkForeign $ + \(sock :: UDPSocket) -> pure $ show sock + IO_UDP_serverSocket_impl_v1 -> mkForeignIOF $ + \(ip :: Util.Text.Text, port :: Util.Text.Text) -> + let maybeIp = readMaybe $ Util.Text.toString ip :: Maybe IP + maybePort = readMaybe $ Util.Text.toString port :: Maybe PortNumber + in case (maybeIp, maybePort) of + (Nothing, _) -> fail "Invalid IP Address" + (_, Nothing) -> fail "Invalid Port Number" + (Just ip, Just pt) -> UDP.serverSocket (ip, pt) + IO_UDP_ListenSocket_toText_impl_v1 -> mkForeign $ + \(sock :: ListenSocket) -> pure $ show sock + IO_UDP_ListenSocket_recvFrom_impl_v1 -> + mkForeignIOF $ + fmap (first Bytes.fromArray) <$> UDP.recvFrom + IO_UDP_ClientSockAddr_toText_v1 -> mkForeign $ + \(sock :: ClientSockAddr) -> pure $ show sock + IO_UDP_ListenSocket_sendTo_impl_v1 -> mkForeignIOF $ + \(socket :: ListenSocket, bytes :: Bytes.Bytes, addr :: ClientSockAddr) -> + UDP.sendTo socket (Bytes.toArray bytes) addr + IO_openFile_impl_v3 -> mkForeignIOF $ \(fnameText :: Util.Text.Text, n :: Int) -> + let fname = Util.Text.toString fnameText + mode = case n of + 0 -> ReadMode + 1 -> WriteMode + 2 -> AppendMode + _ -> ReadWriteMode + in openFile fname mode + IO_closeFile_impl_v3 -> mkForeignIOF hClose + IO_isFileEOF_impl_v3 -> mkForeignIOF hIsEOF + IO_isFileOpen_impl_v3 -> mkForeignIOF hIsOpen + IO_getEcho_impl_v1 -> mkForeignIOF hGetEcho + IO_ready_impl_v1 -> mkForeignIOF hReady + IO_getChar_impl_v1 -> mkForeignIOF hGetChar + IO_isSeekable_impl_v3 -> mkForeignIOF hIsSeekable + IO_seekHandle_impl_v3 -> mkForeignIOF $ + \(h, sm, n) -> hSeek h sm (fromIntegral (n :: Int)) + IO_handlePosition_impl_v3 -> + -- TODO: truncating integer + mkForeignIOF $ + \h -> fromInteger @Word64 <$> hTell h + IO_getBuffering_impl_v3 -> mkForeignIOF hGetBuffering + IO_setBuffering_impl_v3 -> + mkForeignIOF $ + uncurry hSetBuffering + IO_setEcho_impl_v1 -> mkForeignIOF $ uncurry hSetEcho + IO_getLine_impl_v1 -> + mkForeignIOF $ + fmap Util.Text.fromText . Text.IO.hGetLine + IO_getBytes_impl_v3 -> mkForeignIOF $ + \(h, n) -> Bytes.fromArray <$> hGet h n + IO_getSomeBytes_impl_v1 -> mkForeignIOF $ + \(h, n) -> Bytes.fromArray <$> hGetSome h n + IO_putBytes_impl_v3 -> mkForeignIOF $ \(h, bs) -> hPut h (Bytes.toArray bs) + IO_systemTime_impl_v3 -> mkForeignIOF $ + \() -> getPOSIXTime + IO_systemTimeMicroseconds_v1 -> mkForeign $ + \() -> fmap (1e6 *) getPOSIXTime + Clock_internals_monotonic_v1 -> mkForeignIOF $ + \() -> getTime Monotonic + Clock_internals_realtime_v1 -> mkForeignIOF $ + \() -> getTime Realtime + Clock_internals_processCPUTime_v1 -> mkForeignIOF $ + \() -> getTime ProcessCPUTime + Clock_internals_threadCPUTime_v1 -> mkForeignIOF $ + \() -> getTime ThreadCPUTime + Clock_internals_sec_v1 -> mkForeign (\n -> pure (fromIntegral $ sec n :: Word64)) + Clock_internals_nsec_v1 -> mkForeign (\n -> pure (fromIntegral $ nsec n :: Word64)) + Clock_internals_systemTimeZone_v1 -> + mkForeign + ( \secs -> do + TimeZone offset summer name <- getTimeZone (posixSecondsToUTCTime (fromIntegral (secs :: Int))) + pure (offset :: Int, summer, name) + ) + IO_getTempDirectory_impl_v3 -> + mkForeignIOF $ + \() -> chop <$> getTemporaryDirectory + IO_createTempDirectory_impl_v3 -> mkForeignIOF $ \prefix -> do + temp <- getTemporaryDirectory + chop <$> createTempDirectory temp prefix + IO_getCurrentDirectory_impl_v3 -> mkForeignIOF $ + \() -> getCurrentDirectory + IO_setCurrentDirectory_impl_v3 -> mkForeignIOF setCurrentDirectory + IO_fileExists_impl_v3 -> mkForeignIOF doesPathExist + IO_getEnv_impl_v1 -> mkForeignIOF getEnv + IO_getArgs_impl_v1 -> mkForeignIOF $ + \() -> fmap Util.Text.pack <$> SYS.getArgs + IO_isDirectory_impl_v3 -> mkForeignIOF doesDirectoryExist + IO_createDirectory_impl_v3 -> + mkForeignIOF $ + createDirectoryIfMissing True + IO_removeDirectory_impl_v3 -> mkForeignIOF removeDirectoryRecursive + IO_renameDirectory_impl_v3 -> + mkForeignIOF $ + uncurry renameDirectory + IO_directoryContents_impl_v3 -> + mkForeignIOF $ + (fmap Util.Text.pack <$>) . getDirectoryContents + IO_removeFile_impl_v3 -> mkForeignIOF removeFile + IO_renameFile_impl_v3 -> + mkForeignIOF $ + uncurry renameFile + IO_getFileTimestamp_impl_v3 -> + mkForeignIOF $ + fmap utcTimeToPOSIXSeconds . getModificationTime + IO_getFileSize_impl_v3 -> + -- TODO: truncating integer + mkForeignIOF $ + \fp -> fromInteger @Word64 <$> getFileSize fp + IO_serverSocket_impl_v3 -> + mkForeignIOF $ + \( mhst :: Maybe Util.Text.Text, + port + ) -> + fst <$> SYS.bindSock (hostPreference mhst) port + Socket_toText -> mkForeign $ + \(sock :: Socket) -> pure $ show sock + Handle_toText -> mkForeign $ + \(hand :: Handle) -> pure $ show hand + ThreadId_toText -> mkForeign $ + \(threadId :: ThreadId) -> pure $ show threadId + IO_socketPort_impl_v3 -> mkForeignIOF $ + \(handle :: Socket) -> do + n <- SYS.socketPort handle + return (fromIntegral n :: Word64) + IO_listen_impl_v3 -> mkForeignIOF $ + \sk -> SYS.listenSock sk 2048 + IO_clientSocket_impl_v3 -> + mkForeignIOF $ + fmap fst . uncurry SYS.connectSock + IO_closeSocket_impl_v3 -> mkForeignIOF SYS.closeSock + IO_socketAccept_impl_v3 -> + mkForeignIOF $ + fmap fst . SYS.accept + IO_socketSend_impl_v3 -> mkForeignIOF $ + \(sk, bs) -> SYS.send sk (Bytes.toArray bs) + IO_socketReceive_impl_v3 -> mkForeignIOF $ + \(hs, n) -> + maybe mempty Bytes.fromArray <$> SYS.recv hs n + IO_kill_impl_v3 -> mkForeignIOF killThread + IO_delay_impl_v3 -> mkForeignIOF customDelay + IO_stdHandle -> mkForeign $ + \(n :: Int) -> case n of + 0 -> pure SYS.stdin + 1 -> pure SYS.stdout + 2 -> pure SYS.stderr + _ -> die "IO.stdHandle: invalid input." + IO_process_call -> mkForeign $ + \(exe, map Util.Text.unpack -> args) -> + withCreateProcess (proc exe args) $ \_ _ _ p -> + exitDecode <$> waitForProcess p + IO_process_start -> mkForeign $ \(exe, map Util.Text.unpack -> args) -> + runInteractiveProcess exe args Nothing Nothing + IO_process_kill -> mkForeign $ terminateProcess + IO_process_wait -> mkForeign $ + \ph -> exitDecode <$> waitForProcess ph + IO_process_exitCode -> + mkForeign $ + fmap (fmap exitDecode) . getProcessExitCode + MVar_new -> mkForeign $ + \(c :: Val) -> newMVar c + MVar_newEmpty_v2 -> mkForeign $ + \() -> newEmptyMVar @Val + MVar_take_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val) -> takeMVar mv + MVar_tryTake -> mkForeign $ + \(mv :: MVar Val) -> tryTakeMVar mv + MVar_put_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val, x) -> putMVar mv x + MVar_tryPut_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val, x) -> tryPutMVar mv x + MVar_swap_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val, x) -> swapMVar mv x + MVar_isEmpty -> mkForeign $ + \(mv :: MVar Val) -> isEmptyMVar mv + MVar_read_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val) -> readMVar mv + MVar_tryRead_impl_v3 -> mkForeignIOF $ + \(mv :: MVar Val) -> tryReadMVar mv + Char_toText -> mkForeign $ + \(ch :: Char) -> pure (Util.Text.singleton ch) + Text_repeat -> mkForeign $ + \(n :: Word64, txt :: Util.Text.Text) -> pure (Util.Text.replicate (fromIntegral n) txt) + Text_reverse -> + mkForeign $ + pure . Util.Text.reverse + Text_toUppercase -> + mkForeign $ + pure . Util.Text.toUppercase + Text_toLowercase -> + mkForeign $ + pure . Util.Text.toLowercase + Text_toUtf8 -> + mkForeign $ + pure . Util.Text.toUtf8 + Text_fromUtf8_impl_v3 -> + mkForeign $ + pure . mapLeft (\t -> F.Failure Ty.ioFailureRef (Util.Text.pack t) unitValue) . Util.Text.fromUtf8 + Tls_ClientConfig_default -> mkForeign $ + \(hostName :: Util.Text.Text, serverId :: Bytes.Bytes) -> + fmap + ( \store -> + (defaultParamsClient (Util.Text.unpack hostName) (Bytes.toArray serverId)) + { TLS.clientSupported = def {TLS.supportedCiphers = Cipher.ciphersuite_strong}, + TLS.clientShared = def {TLS.sharedCAStore = store} + } + ) + X.getSystemCertificateStore + Tls_ServerConfig_default -> + mkForeign $ + \(certs :: [X.SignedCertificate], key :: X.PrivKey) -> + pure $ + (def :: TLS.ServerParams) + { TLS.serverSupported = def {TLS.supportedCiphers = Cipher.ciphersuite_strong}, + TLS.serverShared = def {TLS.sharedCredentials = Credentials [(X.CertificateChain certs, key)]} + } + Tls_ClientConfig_certificates_set -> + let updateClient :: X.CertificateStore -> TLS.ClientParams -> TLS.ClientParams + updateClient certs client = client {TLS.clientShared = ((clientShared client) {TLS.sharedCAStore = certs})} + in mkForeign $ + \(certs :: [X.SignedCertificate], params :: ClientParams) -> pure $ updateClient (X.makeCertificateStore certs) params + Tls_ServerConfig_certificates_set -> + let updateServer :: X.CertificateStore -> TLS.ServerParams -> TLS.ServerParams + updateServer certs client = client {TLS.serverShared = ((serverShared client) {TLS.sharedCAStore = certs})} + in mkForeign $ + \(certs :: [X.SignedCertificate], params :: ServerParams) -> pure $ updateServer (X.makeCertificateStore certs) params + TVar_new -> mkForeign $ + \(c :: Val) -> unsafeSTMToIO $ STM.newTVar c + TVar_read -> mkForeign $ + \(v :: STM.TVar Val) -> unsafeSTMToIO $ STM.readTVar v + TVar_write -> mkForeign $ + \(v :: STM.TVar Val, c :: Val) -> + unsafeSTMToIO $ STM.writeTVar v c + TVar_newIO -> mkForeign $ + \(c :: Val) -> STM.newTVarIO c + TVar_readIO -> mkForeign $ + \(v :: STM.TVar Val) -> STM.readTVarIO v + TVar_swap -> mkForeign $ + \(v, c :: Val) -> unsafeSTMToIO $ STM.swapTVar v c + STM_retry -> mkForeign $ + \() -> unsafeSTMToIO STM.retry :: IO Val + Promise_new -> mkForeign $ + \() -> newPromise @Val + Promise_read -> mkForeign $ + \(p :: Promise Val) -> readPromise p + Promise_tryRead -> mkForeign $ + \(p :: Promise Val) -> tryReadPromise p + Promise_write -> mkForeign $ + \(p :: Promise Val, a :: Val) -> writePromise p a + Tls_newClient_impl_v3 -> + mkForeignTls $ + \( config :: TLS.ClientParams, + socket :: SYS.Socket + ) -> TLS.contextNew socket config + Tls_newServer_impl_v3 -> + mkForeignTls $ + \( config :: TLS.ServerParams, + socket :: SYS.Socket + ) -> TLS.contextNew socket config + Tls_handshake_impl_v3 -> mkForeignTls $ + \(tls :: TLS.Context) -> TLS.handshake tls + Tls_send_impl_v3 -> + mkForeignTls $ + \( tls :: TLS.Context, + bytes :: Bytes.Bytes + ) -> TLS.sendData tls (Bytes.toLazyByteString bytes) + Tls_decodeCert_impl_v3 -> + let wrapFailure t = F.Failure Ty.tlsFailureRef (Util.Text.pack t) unitValue + decoded :: Bytes.Bytes -> Either String PEM + decoded bytes = case pemParseLBS $ Bytes.toLazyByteString bytes of + Right (pem : _) -> Right pem + Right [] -> Left "no PEM found" + Left l -> Left l + asCert :: PEM -> Either String X.SignedCertificate + asCert pem = X.decodeSignedCertificate $ pemContent pem + in mkForeignTlsE $ + \(bytes :: Bytes.Bytes) -> pure $ mapLeft wrapFailure $ (decoded >=> asCert) bytes + Tls_encodeCert -> mkForeign $ + \(cert :: X.SignedCertificate) -> pure $ Bytes.fromArray $ X.encodeSignedObject cert + Tls_decodePrivateKey -> mkForeign $ + \(bytes :: Bytes.Bytes) -> pure $ X.readKeyFileFromMemory $ L.toStrict $ Bytes.toLazyByteString bytes + Tls_encodePrivateKey -> mkForeign $ + \(privateKey :: X.PrivKey) -> pure $ Util.Text.toUtf8 $ Util.Text.pack $ show privateKey + Tls_receive_impl_v3 -> mkForeignTls $ + \(tls :: TLS.Context) -> do + bs <- TLS.recvData tls + pure $ Bytes.fromArray bs + Tls_terminate_impl_v3 -> mkForeignTls $ + \(tls :: TLS.Context) -> TLS.bye tls + Code_validateLinks -> mkForeign $ + \(lsgs0 :: [(Referent, ANF.Code)]) -> do + let f (msg, rs) = + F.Failure Ty.miscFailureRef (Util.Text.fromText msg) rs + pure . first f $ checkGroupHashes lsgs0 + Code_dependencies -> mkForeign $ + \(ANF.CodeRep sg _) -> + pure $ Wrap Ty.termLinkRef . Ref <$> ANF.groupTermLinks sg + Code_serialize -> mkForeign $ + \(co :: ANF.Code) -> + pure . Bytes.fromArray $ ANF.serializeCode builtinForeignNames co + Code_deserialize -> + mkForeign $ + pure . ANF.deserializeCode . Bytes.toArray + Code_display -> mkForeign $ + \(nm, (ANF.CodeRep sg _)) -> + pure $ ANF.prettyGroup @Symbol (Util.Text.unpack nm) sg "" + Value_dependencies -> + mkForeign $ + pure . fmap (Wrap Ty.termLinkRef . Ref) . ANF.valueTermLinks + Value_serialize -> + mkForeign $ + pure . Bytes.fromArray . ANF.serializeValue + Value_deserialize -> + mkForeign $ + pure . ANF.deserializeValue . Bytes.toArray + Crypto_HashAlgorithm_Sha3_512 -> mkHashAlgorithm "Sha3_512" Hash.SHA3_512 + Crypto_HashAlgorithm_Sha3_256 -> mkHashAlgorithm "Sha3_256" Hash.SHA3_256 + Crypto_HashAlgorithm_Sha2_512 -> mkHashAlgorithm "Sha2_512" Hash.SHA512 + Crypto_HashAlgorithm_Sha2_256 -> mkHashAlgorithm "Sha2_256" Hash.SHA256 + Crypto_HashAlgorithm_Sha1 -> mkHashAlgorithm "Sha1" Hash.SHA1 + Crypto_HashAlgorithm_Blake2b_512 -> mkHashAlgorithm "Blake2b_512" Hash.Blake2b_512 + Crypto_HashAlgorithm_Blake2b_256 -> mkHashAlgorithm "Blake2b_256" Hash.Blake2b_256 + Crypto_HashAlgorithm_Blake2s_256 -> mkHashAlgorithm "Blake2s_256" Hash.Blake2s_256 + Crypto_HashAlgorithm_Md5 -> mkHashAlgorithm "Md5" Hash.MD5 + Crypto_hashBytes -> mkForeign $ + \(HashAlgorithm _ alg, b :: Bytes.Bytes) -> + let ctx = Hash.hashInitWith alg + in pure . Bytes.fromArray . Hash.hashFinalize $ Hash.hashUpdates ctx (Bytes.byteStringChunks b) + Crypto_hmacBytes -> mkForeign $ + \(HashAlgorithm _ alg, key :: Bytes.Bytes, msg :: Bytes.Bytes) -> + let out = u alg $ HMAC.hmac (Bytes.toArray @BA.Bytes key) (Bytes.toArray @BA.Bytes msg) + u :: a -> HMAC.HMAC a -> HMAC.HMAC a + u _ h = h -- to help typechecker along + in pure $ Bytes.fromArray out + Crypto_hash -> mkForeign $ + \(HashAlgorithm _ alg, x) -> + let hashlazy :: + (Hash.HashAlgorithm a) => + a -> + L.ByteString -> + Hash.Digest a + hashlazy _ l = Hash.hashlazy l + in pure . Bytes.fromArray . hashlazy alg $ ANF.serializeValueForHash x + Crypto_hmac -> mkForeign $ + \(HashAlgorithm _ alg, key, x) -> + let hmac :: + (Hash.HashAlgorithm a) => a -> L.ByteString -> HMAC.HMAC a + hmac _ s = + HMAC.finalize + . HMAC.updates + (HMAC.initialize $ Bytes.toArray @BA.Bytes key) + $ L.toChunks s + in pure . Bytes.fromArray . hmac alg $ ANF.serializeValueForHash x + Crypto_Ed25519_sign_impl -> + mkForeign $ + pure . signEd25519Wrapper + Crypto_Ed25519_verify_impl -> + mkForeign $ + pure . verifyEd25519Wrapper + Crypto_Rsa_sign_impl -> + mkForeign $ + pure . signRsaWrapper + Crypto_Rsa_verify_impl -> + mkForeign $ + pure . verifyRsaWrapper + Universal_murmurHash -> + mkForeign $ + pure . asWord64 . hash64 . ANF.serializeValueForHash + IO_randomBytes -> mkForeign $ + \n -> Bytes.fromArray <$> getRandomBytes @IO @ByteString n + Bytes_zlib_compress -> mkForeign $ pure . Bytes.zlibCompress + Bytes_gzip_compress -> mkForeign $ pure . Bytes.gzipCompress + Bytes_zlib_decompress -> mkForeign $ \bs -> + catchAll (pure (Bytes.zlibDecompress bs)) + Bytes_gzip_decompress -> mkForeign $ \bs -> + catchAll (pure (Bytes.gzipDecompress bs)) + Bytes_toBase16 -> mkForeign $ pure . Bytes.toBase16 + Bytes_toBase32 -> mkForeign $ pure . Bytes.toBase32 + Bytes_toBase64 -> mkForeign $ pure . Bytes.toBase64 + Bytes_toBase64UrlUnpadded -> mkForeign $ pure . Bytes.toBase64UrlUnpadded + Bytes_fromBase16 -> + mkForeign $ + pure . mapLeft Util.Text.fromText . Bytes.fromBase16 + Bytes_fromBase32 -> + mkForeign $ + pure . mapLeft Util.Text.fromText . Bytes.fromBase32 + Bytes_fromBase64 -> + mkForeign $ + pure . mapLeft Util.Text.fromText . Bytes.fromBase64 + Bytes_fromBase64UrlUnpadded -> + mkForeign $ + pure . mapLeft Util.Text.fromText . Bytes.fromBase64UrlUnpadded + Bytes_decodeNat64be -> mkForeign $ pure . Bytes.decodeNat64be + Bytes_decodeNat64le -> mkForeign $ pure . Bytes.decodeNat64le + Bytes_decodeNat32be -> mkForeign $ pure . Bytes.decodeNat32be + Bytes_decodeNat32le -> mkForeign $ pure . Bytes.decodeNat32le + Bytes_decodeNat16be -> mkForeign $ pure . Bytes.decodeNat16be + Bytes_decodeNat16le -> mkForeign $ pure . Bytes.decodeNat16le + Bytes_encodeNat64be -> mkForeign $ pure . Bytes.encodeNat64be + Bytes_encodeNat64le -> mkForeign $ pure . Bytes.encodeNat64le + Bytes_encodeNat32be -> mkForeign $ pure . Bytes.encodeNat32be + Bytes_encodeNat32le -> mkForeign $ pure . Bytes.encodeNat32le + Bytes_encodeNat16be -> mkForeign $ pure . Bytes.encodeNat16be + Bytes_encodeNat16le -> mkForeign $ pure . Bytes.encodeNat16le + MutableArray_copyTo_force -> mkForeign $ + \(dst, doff, src, soff, l) -> + let name = "MutableArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ + checkBounds name (PA.sizeofMutableArray src) (soff + l - 1) $ + Right + <$> PA.copyMutableArray @IO @Val + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + MutableByteArray_copyTo_force -> mkForeign $ + \(dst, doff, src, soff, l) -> + let name = "MutableByteArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l) 0 $ + checkBoundsPrim name (PA.sizeofMutableByteArray src) (soff + l) 0 $ + Right + <$> PA.copyMutableByteArray @IO + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + ImmutableArray_copyTo_force -> mkForeign $ + \(dst, doff, src, soff, l) -> + let name = "ImmutableArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ + checkBounds name (PA.sizeofArray src) (soff + l - 1) $ + Right + <$> PA.copyArray @IO @Val + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + ImmutableArray_size -> + mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofArray @Val + MutableArray_size -> + mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofMutableArray @PA.RealWorld @Val + ImmutableByteArray_size -> + mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofByteArray + MutableByteArray_size -> + mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofMutableByteArray @PA.RealWorld + ImmutableByteArray_copyTo_force -> mkForeign $ + \(dst, doff, src, soff, l) -> + let name = "ImmutableByteArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l) 0 $ + checkBoundsPrim name (PA.sizeofByteArray src) (soff + l) 0 $ + Right + <$> PA.copyByteArray @IO + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + MutableArray_read -> + mkForeign $ + checkedRead "MutableArray.read" + MutableByteArray_read8 -> + mkForeign $ + checkedRead8 "MutableByteArray.read8" + MutableByteArray_read16be -> + mkForeign $ + checkedRead16 "MutableByteArray.read16be" + MutableByteArray_read24be -> + mkForeign $ + checkedRead24 "MutableByteArray.read24be" + MutableByteArray_read32be -> + mkForeign $ + checkedRead32 "MutableByteArray.read32be" + MutableByteArray_read40be -> + mkForeign $ + checkedRead40 "MutableByteArray.read40be" + MutableByteArray_read64be -> + mkForeign $ + checkedRead64 "MutableByteArray.read64be" + MutableArray_write -> + mkForeign $ + checkedWrite "MutableArray.write" + MutableByteArray_write8 -> + mkForeign $ + checkedWrite8 "MutableByteArray.write8" + MutableByteArray_write16be -> + mkForeign $ + checkedWrite16 "MutableByteArray.write16be" + MutableByteArray_write32be -> + mkForeign $ + checkedWrite32 "MutableByteArray.write32be" + MutableByteArray_write64be -> + mkForeign $ + checkedWrite64 "MutableByteArray.write64be" + ImmutableArray_read -> + mkForeign $ + checkedIndex "ImmutableArray.read" + ImmutableByteArray_read8 -> + mkForeign $ + checkedIndex8 "ImmutableByteArray.read8" + ImmutableByteArray_read16be -> + mkForeign $ + checkedIndex16 "ImmutableByteArray.read16be" + ImmutableByteArray_read24be -> + mkForeign $ + checkedIndex24 "ImmutableByteArray.read24be" + ImmutableByteArray_read32be -> + mkForeign $ + checkedIndex32 "ImmutableByteArray.read32be" + ImmutableByteArray_read40be -> + mkForeign $ + checkedIndex40 "ImmutableByteArray.read40be" + ImmutableByteArray_read64be -> + mkForeign $ + checkedIndex64 "ImmutableByteArray.read64be" + MutableByteArray_freeze_force -> + mkForeign $ + PA.unsafeFreezeByteArray + MutableArray_freeze_force -> + mkForeign $ + PA.unsafeFreezeArray @IO @Val + MutableByteArray_freeze -> mkForeign $ + \(src, off, len) -> + if len == 0 + then fmap Right . PA.unsafeFreezeByteArray =<< PA.newByteArray 0 + else + checkBoundsPrim + "MutableByteArray.freeze" + (PA.sizeofMutableByteArray src) + (off + len) + 0 + $ Right <$> PA.freezeByteArray src (fromIntegral off) (fromIntegral len) + MutableArray_freeze -> mkForeign $ + \(src :: PA.MutableArray PA.RealWorld Val, off, len) -> + if len == 0 + then fmap Right . PA.unsafeFreezeArray =<< PA.newArray 0 emptyVal + else + checkBounds + "MutableArray.freeze" + (PA.sizeofMutableArray src) + (off + len - 1) + $ Right <$> PA.freezeArray src (fromIntegral off) (fromIntegral len) + MutableByteArray_length -> + mkForeign $ + pure . PA.sizeofMutableByteArray @PA.RealWorld + ImmutableByteArray_length -> + mkForeign $ + pure . PA.sizeofByteArray + IO_array -> mkForeign $ + \n -> PA.newArray n emptyVal + IO_arrayOf -> mkForeign $ + \(v :: Val, n) -> PA.newArray n v + IO_bytearray -> mkForeign $ PA.newByteArray + IO_bytearrayOf -> mkForeign $ + \(init, sz) -> do + arr <- PA.newByteArray sz + PA.fillByteArray arr 0 sz init + pure arr + Scope_array -> mkForeign $ + \n -> PA.newArray n emptyVal + Scope_arrayOf -> mkForeign $ + \(v :: Val, n) -> PA.newArray n v + Scope_bytearray -> mkForeign $ PA.newByteArray + Scope_bytearrayOf -> mkForeign $ + \(init, sz) -> do + arr <- PA.newByteArray sz + PA.fillByteArray arr 0 sz init + pure arr + Text_patterns_literal -> mkForeign $ + \txt -> evaluate . TPat.cpattern $ TPat.Literal txt + Text_patterns_digit -> + mkForeign $ + let v = TPat.cpattern (TPat.Char (TPat.CharRange '0' '9')) in \() -> pure v + Text_patterns_letter -> + mkForeign $ + let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Letter)) in \() -> pure v + Text_patterns_space -> + mkForeign $ + let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Whitespace)) in \() -> pure v + Text_patterns_punctuation -> + mkForeign $ + let v = TPat.cpattern (TPat.Char (TPat.CharClass TPat.Punctuation)) in \() -> pure v + Text_patterns_anyChar -> + mkForeign $ + let v = TPat.cpattern (TPat.Char TPat.Any) in \() -> pure v + Text_patterns_eof -> + mkForeign $ + let v = TPat.cpattern TPat.Eof in \() -> pure v + Text_patterns_charRange -> mkForeign $ + \(beg, end) -> evaluate . TPat.cpattern . TPat.Char $ TPat.CharRange beg end + Text_patterns_notCharRange -> mkForeign $ + \(beg, end) -> evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharRange beg end + Text_patterns_charIn -> mkForeign $ \ccs -> do + cs <- for ccs $ \case + CharVal c -> pure c + _ -> die "Text.patterns.charIn: non-character closure" + evaluate . TPat.cpattern . TPat.Char $ TPat.CharSet cs + Text_patterns_notCharIn -> mkForeign $ \ccs -> do + cs <- for ccs $ \case + CharVal c -> pure c + _ -> die "Text.patterns.notCharIn: non-character closure" + evaluate . TPat.cpattern . TPat.Char . TPat.Not $ TPat.CharSet cs + Pattern_many -> mkForeign $ + \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many False p + Pattern_many_corrected -> mkForeign $ + \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many True p + Pattern_capture -> mkForeign $ + \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Capture p + Pattern_captureAs -> mkForeign $ + \(t, (TPat.CP p _)) -> evaluate . TPat.cpattern $ TPat.CaptureAs t p + Pattern_join -> mkForeign $ \ps -> + evaluate . TPat.cpattern . TPat.Join $ map (\(TPat.CP p _) -> p) ps + Pattern_or -> mkForeign $ + \(TPat.CP l _, TPat.CP r _) -> evaluate . TPat.cpattern $ TPat.Or l r + Pattern_replicate -> mkForeign $ + \(m0 :: Word64, n0 :: Word64, TPat.CP p _) -> + let m = fromIntegral m0; n = fromIntegral n0 + in evaluate . TPat.cpattern $ TPat.Replicate m n p + Pattern_run -> mkForeign $ + \(TPat.CP _ matcher, input :: Text) -> pure $ matcher input + Pattern_isMatch -> mkForeign $ + \(TPat.CP _ matcher, input :: Text) -> pure . isJust $ matcher input + Char_Class_any -> mkForeign $ \() -> pure TPat.Any + Char_Class_not -> mkForeign $ pure . TPat.Not + Char_Class_and -> mkForeign $ \(a, b) -> pure $ TPat.Intersect a b + Char_Class_or -> mkForeign $ \(a, b) -> pure $ TPat.Union a b + Char_Class_range -> mkForeign $ \(a, b) -> pure $ TPat.CharRange a b + Char_Class_anyOf -> mkForeign $ \ccs -> do + cs <- for ccs $ \case + CharVal c -> pure c + _ -> die "Text.patterns.charIn: non-character closure" + evaluate $ TPat.CharSet cs + Char_Class_alphanumeric -> mkForeign $ \() -> pure (TPat.CharClass TPat.AlphaNum) + Char_Class_upper -> mkForeign $ \() -> pure (TPat.CharClass TPat.Upper) + Char_Class_lower -> mkForeign $ \() -> pure (TPat.CharClass TPat.Lower) + Char_Class_whitespace -> mkForeign $ \() -> pure (TPat.CharClass TPat.Whitespace) + Char_Class_control -> mkForeign $ \() -> pure (TPat.CharClass TPat.Control) + Char_Class_printable -> mkForeign $ \() -> pure (TPat.CharClass TPat.Printable) + Char_Class_mark -> mkForeign $ \() -> pure (TPat.CharClass TPat.MarkChar) + Char_Class_number -> mkForeign $ \() -> pure (TPat.CharClass TPat.Number) + Char_Class_punctuation -> mkForeign $ \() -> pure (TPat.CharClass TPat.Punctuation) + Char_Class_symbol -> mkForeign $ \() -> pure (TPat.CharClass TPat.Symbol) + Char_Class_separator -> mkForeign $ \() -> pure (TPat.CharClass TPat.Separator) + Char_Class_letter -> mkForeign $ \() -> pure (TPat.CharClass TPat.Letter) + Char_Class_is -> mkForeign $ \(cl, c) -> evaluate $ TPat.charPatternPred cl c + Text_patterns_char -> mkForeign $ \c -> + let v = TPat.cpattern (TPat.Char c) in pure v + where + chop = reverse . dropWhile isPathSeparator . reverse + + hostPreference :: Maybe Util.Text.Text -> SYS.HostPreference + hostPreference Nothing = SYS.HostAny + hostPreference (Just host) = SYS.Host $ Util.Text.unpack host + + mx :: Word64 + mx = fromIntegral (maxBound :: Int) + + customDelay :: Word64 -> IO () + customDelay n + | n < mx = threadDelay (fromIntegral n) + | otherwise = threadDelay maxBound >> customDelay (n - mx) + + exitDecode ExitSuccess = 0 + exitDecode (ExitFailure n) = n + + catchAll :: (MonadCatch m, MonadIO m, NFData a) => m a -> m (Either Util.Text.Text a) + catchAll e = do + e <- Exception.tryAnyDeep e + pure $ case e of + Left se -> Left (Util.Text.pack (show se)) + Right a -> Right a + +{-# INLINE mkHashAlgorithm #-} +mkHashAlgorithm :: forall alg. (Hash.HashAlgorithm alg) => Data.Text.Text -> alg -> Args -> Stack -> IO Stack +mkHashAlgorithm txt alg = + let algoRef = Builtin ("crypto.HashAlgorithm." <> txt) + in mkForeign $ \() -> pure (HashAlgorithm algoRef alg) + +{-# INLINE mkForeign #-} +mkForeign :: (ForeignConvention a, ForeignConvention b) => (a -> IO b) -> Args -> Stack -> IO Stack +mkForeign !f !args !stk = do + args <- decodeArgs args stk + res <- f args + writeForeign stk res + where + decodeArgs :: (ForeignConvention x) => Args -> Stack -> IO x + decodeArgs !args !stk = + readForeign (argsToLists args) stk >>= \case + ([], a) -> pure a + _ -> + error + "mkForeign: too many arguments for foreign function" --- Foreign functions operating on stacks -data ForeignFunc where - FF :: - (XStack -> Args -> IO a) -> - (XStack -> r -> IOStack) -> - (a -> IO r) -> - ForeignFunc - -instance Show ForeignFunc where - show _ = "ForeignFunc" +{-# INLINE mkForeignIOF #-} +mkForeignIOF :: + (ForeignConvention a, ForeignConvention r) => + (a -> IO r) -> + Args -> + Stack -> + IO Stack +mkForeignIOF f = mkForeign $ \a -> tryIOE (f a) + where + tryIOE :: IO a -> IO (Either (F.Failure Val) a) + tryIOE = fmap handleIOE . UnliftIO.try + handleIOE :: Either IOException a -> Either (F.Failure Val) a + handleIOE (Left e) = Left $ F.Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue + handleIOE (Right a) = Right a + +{-# INLINE mkForeignTls #-} +mkForeignTls :: + forall a r. + (ForeignConvention a, ForeignConvention r) => + (a -> IO r) -> + Args -> + Stack -> + IO Stack +mkForeignTls f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) + where + tryIO1 :: IO r -> IO (Either TLS.TLSException r) + tryIO1 = UnliftIO.try + tryIO2 :: IO (Either TLS.TLSException r) -> IO (Either IOException (Either TLS.TLSException r)) + tryIO2 = UnliftIO.try + flatten :: Either IOException (Either TLS.TLSException r) -> Either ((F.Failure Val)) r + flatten (Left e) = Left (F.Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Left e)) = Left (F.Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Right a)) = Right a + +{-# INLINE mkForeignTlsE #-} +mkForeignTlsE :: + forall a r. + (ForeignConvention a, ForeignConvention r) => + (a -> IO (Either Failure r)) -> + Args -> + Stack -> + IO Stack +mkForeignTlsE f = mkForeign $ \a -> fmap flatten (tryIO2 (tryIO1 (f a))) + where + tryIO1 :: IO (Either Failure r) -> IO (Either TLS.TLSException (Either Failure r)) + tryIO1 = UnliftIO.try + tryIO2 :: IO (Either TLS.TLSException (Either Failure r)) -> IO (Either IOException (Either TLS.TLSException (Either Failure r))) + tryIO2 = UnliftIO.try + flatten :: Either IOException (Either TLS.TLSException (Either Failure r)) -> Either Failure r + flatten (Left e) = Left (F.Failure Ty.ioFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Left e)) = Left (F.Failure Ty.tlsFailureRef (Util.Text.pack (show e)) unitValue) + flatten (Right (Right (Left e))) = Left e + flatten (Right (Right (Right a))) = Right a + +{-# INLINE unsafeSTMToIO #-} +unsafeSTMToIO :: STM.STM a -> IO a +unsafeSTMToIO (STM.STM m) = IO m + +signEd25519Wrapper :: + (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes +signEd25519Wrapper (secret0, public0, msg0) = case validated of + CryptoFailed err -> + Left (F.Failure Ty.cryptoFailureRef (errMsg err) unitValue) + CryptoPassed (secret, public) -> + Right . Bytes.fromArray $ Ed25519.sign secret public msg + where + msg = Bytes.toArray msg0 :: ByteString + validated = + (,) + <$> Ed25519.secretKey (Bytes.toArray secret0 :: ByteString) + <*> Ed25519.publicKey (Bytes.toArray public0 :: ByteString) + + errMsg CryptoError_PublicKeySizeInvalid = + "ed25519: Public key size invalid" + errMsg CryptoError_SecretKeySizeInvalid = + "ed25519: Secret key size invalid" + errMsg CryptoError_SecretKeyStructureInvalid = + "ed25519: Secret key structure invalid" + errMsg _ = "ed25519: unexpected error" + +verifyEd25519Wrapper :: + (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bool +verifyEd25519Wrapper (public0, msg0, sig0) = case validated of + CryptoFailed err -> + Left $ F.Failure Ty.cryptoFailureRef (errMsg err) unitValue + CryptoPassed (public, sig) -> + Right $ Ed25519.verify public msg sig + where + msg = Bytes.toArray msg0 :: ByteString + validated = + (,) + <$> Ed25519.publicKey (Bytes.toArray public0 :: ByteString) + <*> Ed25519.signature (Bytes.toArray sig0 :: ByteString) + + errMsg CryptoError_PublicKeySizeInvalid = + "ed25519: Public key size invalid" + errMsg CryptoError_SecretKeySizeInvalid = + "ed25519: Secret key size invalid" + errMsg CryptoError_SecretKeyStructureInvalid = + "ed25519: Secret key structure invalid" + errMsg _ = "ed25519: unexpected error" + +signRsaWrapper :: + (Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes +signRsaWrapper (secret0, msg0) = case validated of + Left err -> + Left (F.Failure Ty.cryptoFailureRef err unitValue) + Right secret -> + case RSA.sign Nothing (Just Hash.SHA256) secret msg of + Left err -> Left (F.Failure Ty.cryptoFailureRef (Rsa.rsaErrorToText err) unitValue) + Right signature -> Right $ Bytes.fromByteString signature + where + msg = Bytes.toArray msg0 :: ByteString + validated = Rsa.parseRsaPrivateKey (Bytes.toArray secret0 :: ByteString) + +verifyRsaWrapper :: + (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bool +verifyRsaWrapper (public0, msg0, sig0) = case validated of + Left err -> + Left $ F.Failure Ty.cryptoFailureRef err unitValue + Right public -> + Right $ RSA.verify (Just Hash.SHA256) public msg sig + where + msg = Bytes.toArray msg0 :: ByteString + sig = Bytes.toArray sig0 :: ByteString + validated = Rsa.parseRsaPublicKey (Bytes.toArray public0 :: ByteString) -instance Eq ForeignFunc where - _ == _ = internalBug "Eq ForeignFunc" +type Failure = F.Failure Val -instance Ord ForeignFunc where - compare _ _ = internalBug "Ord ForeignFunc" +checkBounds :: Text -> Int -> Word64 -> IO (Either Failure b) -> IO (Either Failure b) +checkBounds name l w act + | w < fromIntegral l = act + | otherwise = pure $ Left err + where + msg = name <> ": array index out of bounds" + err = F.Failure Ty.arrayFailureRef msg (natValue w) + +-- Performs a bounds check on a byte array. Strategy is as follows: +-- +-- isz = signed array size-in-bytes +-- off = unsigned byte offset into the array +-- esz = unsigned number of bytes to be read +-- +-- 1. Turn the signed size-in-bytes of the array unsigned +-- 2. Add the offset to the to-be-read number to get the maximum size needed +-- 3. Check that the actual array size is at least as big as the needed size +-- 4. Check that the offset is less than the size +-- +-- Step 4 ensures that step 3 has not overflowed. Since an actual array size can +-- only be 63 bits (since it is signed), the only way for 3 to overflow is if +-- the offset is larger than a possible array size, since it would need to be +-- 2^64-k, where k is the small (<=8) number of bytes to be read. +checkBoundsPrim :: + Text -> Int -> Word64 -> Word64 -> IO (Either Failure b) -> IO (Either Failure b) +checkBoundsPrim name isz off esz act + | w > bsz || off > bsz = pure $ Left err + | otherwise = act + where + msg = name <> ": array index out of bounds" + err = F.Failure Ty.arrayFailureRef msg (natValue off) + + bsz = fromIntegral isz + w = off + esz + +type RW = PA.PrimState IO + +checkedRead :: + Text -> (PA.MutableArray RW Val, Word64) -> IO (Either Failure Val) +checkedRead name (arr, w) = + checkBounds + name + (PA.sizeofMutableArray arr) + w + (Right <$> PA.readArray arr (fromIntegral w)) + +checkedWrite :: + Text -> (PA.MutableArray RW Val, Word64, Val) -> IO (Either Failure ()) +checkedWrite name (arr, w, v) = + checkBounds + name + (PA.sizeofMutableArray arr) + w + (Right <$> PA.writeArray arr (fromIntegral w) v) + +checkedIndex :: + Text -> (PA.Array Val, Word64) -> IO (Either Failure Val) +checkedIndex name (arr, w) = + checkBounds + name + (PA.sizeofArray arr) + w + (Right <$> PA.indexArrayM arr (fromIntegral w)) + +checkedRead8 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead8 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 1 $ + (Right . fromIntegral) <$> PA.readByteArray @Word8 arr j + where + j = fromIntegral i + +checkedRead16 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead16 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 2 $ + mk16 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + where + j = fromIntegral i + +checkedRead24 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead24 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 3 $ + mk24 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) + where + j = fromIntegral i + +checkedRead32 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead32 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 4 $ + mk32 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) + <*> PA.readByteArray @Word8 arr (j + 3) + where + j = fromIntegral i + +checkedRead40 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead40 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 6 $ + mk40 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) + <*> PA.readByteArray @Word8 arr (j + 3) + <*> PA.readByteArray @Word8 arr (j + 4) + where + j = fromIntegral i + +checkedRead64 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead64 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 8 $ + mk64 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) + <*> PA.readByteArray @Word8 arr (j + 3) + <*> PA.readByteArray @Word8 arr (j + 4) + <*> PA.readByteArray @Word8 arr (j + 5) + <*> PA.readByteArray @Word8 arr (j + 6) + <*> PA.readByteArray @Word8 arr (j + 7) + where + j = fromIntegral i + +mk16 :: Word8 -> Word8 -> Either Failure Word64 +mk16 b0 b1 = Right $ (fromIntegral b0 `shiftL` 8) .|. (fromIntegral b1) + +mk24 :: Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk24 b0 b1 b2 = + Right $ + (fromIntegral b0 `shiftL` 16) + .|. (fromIntegral b1 `shiftL` 8) + .|. (fromIntegral b2) + +mk32 :: Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk32 b0 b1 b2 b3 = + Right $ + (fromIntegral b0 `shiftL` 24) + .|. (fromIntegral b1 `shiftL` 16) + .|. (fromIntegral b2 `shiftL` 8) + .|. (fromIntegral b3) + +mk40 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk40 b0 b1 b2 b3 b4 = + Right $ + (fromIntegral b0 `shiftL` 32) + .|. (fromIntegral b1 `shiftL` 24) + .|. (fromIntegral b2 `shiftL` 16) + .|. (fromIntegral b3 `shiftL` 8) + .|. (fromIntegral b4) + +mk64 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk64 b0 b1 b2 b3 b4 b5 b6 b7 = + Right $ + (fromIntegral b0 `shiftL` 56) + .|. (fromIntegral b1 `shiftL` 48) + .|. (fromIntegral b2 `shiftL` 40) + .|. (fromIntegral b3 `shiftL` 32) + .|. (fromIntegral b4 `shiftL` 24) + .|. (fromIntegral b5 `shiftL` 16) + .|. (fromIntegral b6 `shiftL` 8) + .|. (fromIntegral b7) + +checkedWrite8 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite8 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 1 $ do + PA.writeByteArray arr j (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +checkedWrite16 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite16 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 2 $ do + PA.writeByteArray arr j (fromIntegral $ v `shiftR` 8 :: Word8) + PA.writeByteArray arr (j + 1) (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +checkedWrite32 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite32 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 4 $ do + PA.writeByteArray arr j (fromIntegral $ v `shiftR` 24 :: Word8) + PA.writeByteArray arr (j + 1) (fromIntegral $ v `shiftR` 16 :: Word8) + PA.writeByteArray arr (j + 2) (fromIntegral $ v `shiftR` 8 :: Word8) + PA.writeByteArray arr (j + 3) (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +checkedWrite64 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite64 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 8 $ do + PA.writeByteArray arr j (fromIntegral $ v `shiftR` 56 :: Word8) + PA.writeByteArray arr (j + 1) (fromIntegral $ v `shiftR` 48 :: Word8) + PA.writeByteArray arr (j + 2) (fromIntegral $ v `shiftR` 40 :: Word8) + PA.writeByteArray arr (j + 3) (fromIntegral $ v `shiftR` 32 :: Word8) + PA.writeByteArray arr (j + 4) (fromIntegral $ v `shiftR` 24 :: Word8) + PA.writeByteArray arr (j + 5) (fromIntegral $ v `shiftR` 16 :: Word8) + PA.writeByteArray arr (j + 6) (fromIntegral $ v `shiftR` 8 :: Word8) + PA.writeByteArray arr (j + 7) (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +-- index single byte +checkedIndex8 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex8 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 1 . pure $ + let j = fromIntegral i + in Right . fromIntegral $ PA.indexByteArray @Word8 arr j + +-- index 16 big-endian +checkedIndex16 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex16 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 2 . pure $ + let j = fromIntegral i + in mk16 (PA.indexByteArray arr j) (PA.indexByteArray arr (j + 1)) + +-- index 32 big-endian +checkedIndex24 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex24 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 3 . pure $ + let j = fromIntegral i + in mk24 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + +-- index 32 big-endian +checkedIndex32 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex32 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 4 . pure $ + let j = fromIntegral i + in mk32 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + (PA.indexByteArray arr (j + 3)) + +-- index 40 big-endian +checkedIndex40 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex40 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 5 . pure $ + let j = fromIntegral i + in mk40 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + (PA.indexByteArray arr (j + 3)) + (PA.indexByteArray arr (j + 4)) + +-- index 64 big-endian +checkedIndex64 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex64 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 8 . pure $ + let j = fromIntegral i + in mk64 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + (PA.indexByteArray arr (j + 3)) + (PA.indexByteArray arr (j + 4)) + (PA.indexByteArray arr (j + 5)) + (PA.indexByteArray arr (j + 6)) + (PA.indexByteArray arr (j + 7)) class ForeignConvention a where readForeign :: @@ -76,35 +1322,17 @@ class ForeignConvention a where writeForeign :: Stack -> a -> IO Stack -mkForeign :: - forall a r. - (ForeignConvention a, ForeignConvention r) => - (a -> IO r) -> - ForeignFunc -mkForeign ev = FF readArgs doWrite ev - where - doWrite :: XStack -> r -> IOStack - doWrite stk a = case writeForeign (packXStack stk) a of - (IO f) -> \state -> case f state of - (# state', stk #) -> (# state', unpackXStack stk #) - readArgs (packXStack -> stk) (argsToLists -> args) = - readForeign args stk >>= \case - ([], a) -> pure a - _ -> - internalBug - "mkForeign: too many arguments for foreign function" - instance ForeignConvention Int where - readForeign (i : args) stk = (args,) <$> peekOffI stk i - readForeign [] _ = foreignCCError "Int" - writeForeign stk i = do + readForeign (i : args) !stk = (args,) <$> peekOffI stk i + readForeign [] !_ = foreignCCError "Int" + writeForeign !stk !i = do stk <- bump stk stk <$ pokeI stk i instance ForeignConvention Word64 where - readForeign (i : args) stk = (args,) <$> peekOffN stk i - readForeign [] _ = foreignCCError "Word64" - writeForeign stk n = do + readForeign (i : args) !stk = (args,) <$> peekOffN stk i + readForeign [] !_ = foreignCCError "Word64" + writeForeign !stk !n = do stk <- bump stk stk <$ pokeN stk n @@ -123,25 +1351,25 @@ instance ForeignConvention Word32 where writeForeign = writeForeignAs (fromIntegral :: Word32 -> Word64) instance ForeignConvention Char where - readForeign (i : args) stk = (args,) <$> peekOffC stk i - readForeign [] _ = foreignCCError "Char" - writeForeign stk ch = do + readForeign (i : args) !stk = (args,) <$> peekOffC stk i + readForeign [] !_ = foreignCCError "Char" + writeForeign !stk !ch = do stk <- bump stk stk <$ pokeC stk ch instance ForeignConvention Val where - readForeign (i : args) stk = (args,) <$> peekOff stk i - readForeign [] _ = foreignCCError "Val" - writeForeign stk v = do + readForeign (i : args) !stk = (args,) <$> peekOff stk i + readForeign [] !_ = foreignCCError "Val" + writeForeign !stk !v = do stk <- bump stk stk <$ (poke stk =<< evaluate v) -- In reality this fixes the type to be 'RClosure', but allows us to defer -- the typechecker a bit and avoid a bunch of annoying type annotations. instance ForeignConvention Closure where - readForeign (i : args) stk = (args,) <$> bpeekOff stk i - readForeign [] _ = foreignCCError "Closure" - writeForeign stk c = do + readForeign (i : args) !stk = (args,) <$> bpeekOff stk i + readForeign [] !_ = foreignCCError "Closure" + writeForeign !stk !c = do stk <- bump stk stk <$ (bpoke stk =<< evaluate c) @@ -149,7 +1377,7 @@ instance ForeignConvention Text where readForeign = readForeignBuiltin writeForeign = writeForeignBuiltin -instance ForeignConvention Bytes where +instance ForeignConvention Unison.Util.Bytes.Bytes where readForeign = readForeignBuiltin writeForeign = writeForeignBuiltin @@ -174,17 +1402,17 @@ instance ForeignConvention POSIXTime where writeForeign = writeForeignAs (round :: POSIXTime -> Int) instance (ForeignConvention a) => ForeignConvention (Maybe a) where - readForeign (i : args) stk = + readForeign (i : args) !stk = upeekOff stk i >>= \case 0 -> pure (args, Nothing) 1 -> fmap Just <$> readForeign args stk _ -> foreignCCError "Maybe" - readForeign [] _ = foreignCCError "Maybe" + readForeign [] !_ = foreignCCError "Maybe" - writeForeign stk Nothing = do + writeForeign !stk Nothing = do stk <- bump stk stk <$ pokeTag stk 0 - writeForeign stk (Just x) = do + writeForeign !stk (Just x) = do stk <- writeForeign stk x stk <- bump stk stk <$ pokeTag stk 1 @@ -193,18 +1421,18 @@ instance (ForeignConvention a, ForeignConvention b) => ForeignConvention (Either a b) where - readForeign (i : args) stk = + readForeign (i : args) !stk = peekTagOff stk i >>= \case 0 -> readForeignAs Left args stk 1 -> readForeignAs Right args stk _ -> foreignCCError "Either" - readForeign _ _ = foreignCCError "Either" + readForeign !_ !_ = foreignCCError "Either" - writeForeign stk (Left a) = do + writeForeign !stk !(Left a) = do stk <- writeForeign stk a stk <- bump stk stk <$ pokeTag stk 0 - writeForeign stk (Right b) = do + writeForeign !stk !(Right b) = do stk <- writeForeign stk b stk <- bump stk stk <$ pokeTag stk 1 @@ -244,7 +1472,7 @@ readForeignAs :: [Int] -> Stack -> IO ([Int], b) -readForeignAs f args stk = fmap f <$> readForeign args stk +readForeignAs !f !args !stk = fmap f <$> readForeign args stk writeForeignAs :: (ForeignConvention b) => @@ -252,7 +1480,7 @@ writeForeignAs :: Stack -> a -> IO Stack -writeForeignAs f stk x = writeForeign stk (f x) +writeForeignAs !f !stk !x = writeForeign stk (f x) readForeignEnum :: (Enum a) => @@ -287,27 +1515,29 @@ writeTypeLink :: Reference -> IO Stack writeTypeLink = writeForeignAs (Foreign . Wrap typeLinkRef) +{-# INLINE writeTypeLink #-} readTypelink :: [Int] -> Stack -> IO ([Int], Reference) readTypelink = readForeignAs (unwrapForeign . marshalToForeign) +{-# INLINE readTypelink #-} instance ForeignConvention Double where - readForeign (i : args) stk = (args,) <$> peekOffD stk i - readForeign _ _ = foreignCCError "Double" - writeForeign stk d = - bump stk >>= \stk -> do + readForeign (i : args) !stk = (args,) <$> peekOffD stk i + readForeign !_ !_ = foreignCCError "Double" + writeForeign !stk !d = + bump stk >>= \(!stk) -> do pokeD stk d pure stk instance ForeignConvention Bool where - readForeign (i : args) stk = do + readForeign (i : args) !stk = do b <- peekOffBool stk i pure (args, b) - readForeign _ _ = foreignCCError "Bool" - writeForeign stk b = do + readForeign !_ !_ = foreignCCError "Bool" + writeForeign !stk !b = do stk <- bump stk pokeBool stk b pure stk @@ -325,30 +1555,30 @@ instance ForeignConvention IOMode where writeForeign = writeForeignEnum instance ForeignConvention () where - readForeign args _ = pure (args, ()) - writeForeign stk _ = pure stk + readForeign !args !_ = pure (args, ()) + writeForeign !stk !_ = pure stk instance (ForeignConvention a, ForeignConvention b) => ForeignConvention (a, b) where - readForeign args stk = do + readForeign !args !stk = do (args, a) <- readForeign args stk (args, b) <- readForeign args stk pure (args, (a, b)) - writeForeign stk (x, y) = do + writeForeign !stk (x, y) = do stk <- writeForeign stk y writeForeign stk x -instance (ForeignConvention a) => ForeignConvention (Failure a) where - readForeign args stk = do +instance (ForeignConvention a) => ForeignConvention (F.Failure a) where + readForeign !args !stk = do (args, typeref) <- readTypelink args stk (args, message) <- readForeign args stk (args, any) <- readForeign args stk - pure (args, Failure typeref message any) + pure (args, F.Failure typeref message any) - writeForeign stk (Failure typeref message any) = do + writeForeign !stk (F.Failure typeref message any) = do stk <- writeForeign stk any stk <- writeForeign stk message writeTypeLink stk typeref @@ -360,13 +1590,13 @@ instance ) => ForeignConvention (a, b, c) where - readForeign args stk = do + readForeign !args !stk = do (args, a) <- readForeign args stk (args, b) <- readForeign args stk (args, c) <- readForeign args stk pure (args, (a, b, c)) - writeForeign stk (a, b, c) = do + writeForeign !stk (a, b, c) = do stk <- writeForeign stk c stk <- writeForeign stk b writeForeign stk a @@ -379,14 +1609,14 @@ instance ) => ForeignConvention (a, b, c, d) where - readForeign args stk = do + readForeign !args !stk = do (args, a) <- readForeign args stk (args, b) <- readForeign args stk (args, c) <- readForeign args stk (args, d) <- readForeign args stk pure (args, (a, b, c, d)) - writeForeign stk (a, b, c, d) = do + writeForeign !stk (a, b, c, d) = do stk <- writeForeign stk d stk <- writeForeign stk c stk <- writeForeign stk b @@ -401,7 +1631,7 @@ instance ) => ForeignConvention (a, b, c, d, e) where - readForeign args stk = do + readForeign !args !stk = do (args, a) <- readForeign args stk (args, b) <- readForeign args stk (args, c) <- readForeign args stk @@ -409,7 +1639,7 @@ instance (args, e) <- readForeign args stk pure (args, (a, b, c, d, e)) - writeForeign stk (a, b, c, d, e) = do + writeForeign !stk (a, b, c, d, e) = do stk <- writeForeign stk e stk <- writeForeign stk d stk <- writeForeign stk c @@ -423,7 +1653,7 @@ block'buf = fromIntegral Ty.bufferModeBlockBufferingId sblock'buf = fromIntegral Ty.bufferModeSizedBlockBufferingId instance ForeignConvention BufferMode where - readForeign (i : args) stk = + readForeign (i : args) !stk = peekOffN stk i >>= \case t | t == no'buf -> pure (args, NoBuffering) @@ -435,10 +1665,10 @@ instance ForeignConvention BufferMode where | otherwise -> foreignCCError $ "BufferMode (unknown tag: " <> show t <> ")" - readForeign _ _ = foreignCCError $ "BufferMode (empty stack)" + readForeign !_ !_ = foreignCCError $ "BufferMode (empty stack)" - writeForeign stk bm = - bump stk >>= \stk -> + writeForeign !stk !bm = + bump stk >>= \(stk) -> case bm of NoBuffering -> stk <$ pokeN stk no'buf LineBuffering -> stk <$ pokeN stk line'buf @@ -451,20 +1681,20 @@ instance ForeignConvention BufferMode where -- In reality this fixes the type to be 'RClosure', but allows us to defer -- the typechecker a bit and avoid a bunch of annoying type annotations. instance {-# OVERLAPPING #-} ForeignConvention [Val] where - readForeign (i : args) stk = + readForeign (i : args) !stk = (args,) . toList <$> peekOffS stk i - readForeign _ _ = foreignCCError "[Val]" - writeForeign stk l = do + readForeign !_ !_ = foreignCCError "[Val]" + writeForeign !stk !l = do stk <- bump stk stk <$ pokeS stk (Sq.fromList l) -- In reality this fixes the type to be 'RClosure', but allows us to defer -- the typechecker a bit and avoid a bunch of annoying type annotations. instance {-# OVERLAPPING #-} ForeignConvention [Closure] where - readForeign (i : args) stk = + readForeign (i : args) !stk = (args,) . fmap getBoxedVal . toList <$> peekOffS stk i - readForeign _ _ = foreignCCError "[Closure]" - writeForeign stk l = do + readForeign !_ !_ = foreignCCError "[Closure]" + writeForeign !stk !l = do stk <- bump stk stk <$ pokeS stk (Sq.fromList . fmap BoxedVal $ l) @@ -544,25 +1774,25 @@ unwrapForeignClosure :: Closure -> a unwrapForeignClosure = unwrapForeign . marshalToForeign instance {-# OVERLAPPABLE #-} (BuiltinForeign a, BuiltinForeign b) => ForeignConvention [(a, b)] where - readForeign (i : args) stk = + readForeign (i : args) !stk = (args,) . fmap (fromUnisonPair . getBoxedVal) . toList <$> peekOffS stk i - readForeign _ _ = foreignCCError "[(a,b)]" + readForeign !_ !_ = foreignCCError "[(a,b)]" - writeForeign stk l = do + writeForeign !stk !l = do stk <- bump stk stk <$ pokeS stk (boxedVal . toUnisonPair <$> Sq.fromList l) instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention [b] where - readForeign (i : args) stk = + readForeign (i : args) !stk = (args,) . fmap (unwrapForeignClosure . getBoxedVal) . toList <$> peekOffS stk i - readForeign _ _ = foreignCCError "[b]" - writeForeign stk l = do + readForeign !_ !_ = foreignCCError "[b]" + writeForeign !stk !l = do stk <- bump stk stk <$ pokeS stk (boxedVal . Foreign . wrapBuiltin <$> Sq.fromList l) diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function/Type.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function/Type.hs new file mode 100644 index 0000000000..97796223e9 --- /dev/null +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function/Type.hs @@ -0,0 +1,506 @@ +module Unison.Runtime.Foreign.Function.Type + ( ForeignFunc (..), + foreignFuncBuiltinName, + ) +where + +import Data.Text (Text) + +-- | Enum representing every foreign call. +data ForeignFunc + = IO_UDP_clientSocket_impl_v1 + | IO_UDP_UDPSocket_recv_impl_v1 + | IO_UDP_UDPSocket_send_impl_v1 + | IO_UDP_UDPSocket_close_impl_v1 + | IO_UDP_ListenSocket_close_impl_v1 + | IO_UDP_UDPSocket_toText_impl_v1 + | IO_UDP_serverSocket_impl_v1 + | IO_UDP_ListenSocket_toText_impl_v1 + | IO_UDP_ListenSocket_recvFrom_impl_v1 + | IO_UDP_ClientSockAddr_toText_v1 + | IO_UDP_ListenSocket_sendTo_impl_v1 + | IO_openFile_impl_v3 + | IO_closeFile_impl_v3 + | IO_isFileEOF_impl_v3 + | IO_isFileOpen_impl_v3 + | IO_getEcho_impl_v1 + | IO_ready_impl_v1 + | IO_getChar_impl_v1 + | IO_isSeekable_impl_v3 + | IO_seekHandle_impl_v3 + | IO_handlePosition_impl_v3 + | IO_getBuffering_impl_v3 + | IO_setBuffering_impl_v3 + | IO_setEcho_impl_v1 + | IO_getLine_impl_v1 + | IO_getBytes_impl_v3 + | IO_getSomeBytes_impl_v1 + | IO_putBytes_impl_v3 + | IO_systemTime_impl_v3 + | IO_systemTimeMicroseconds_v1 + | Clock_internals_monotonic_v1 + | Clock_internals_realtime_v1 + | Clock_internals_processCPUTime_v1 + | Clock_internals_threadCPUTime_v1 + | Clock_internals_sec_v1 + | Clock_internals_nsec_v1 + | Clock_internals_systemTimeZone_v1 + | IO_getTempDirectory_impl_v3 + | IO_createTempDirectory_impl_v3 + | IO_getCurrentDirectory_impl_v3 + | IO_setCurrentDirectory_impl_v3 + | IO_fileExists_impl_v3 + | IO_getEnv_impl_v1 + | IO_getArgs_impl_v1 + | IO_isDirectory_impl_v3 + | IO_createDirectory_impl_v3 + | IO_removeDirectory_impl_v3 + | IO_renameDirectory_impl_v3 + | IO_directoryContents_impl_v3 + | IO_removeFile_impl_v3 + | IO_renameFile_impl_v3 + | IO_getFileTimestamp_impl_v3 + | IO_getFileSize_impl_v3 + | IO_serverSocket_impl_v3 + | Socket_toText + | Handle_toText + | ThreadId_toText + | IO_socketPort_impl_v3 + | IO_listen_impl_v3 + | IO_clientSocket_impl_v3 + | IO_closeSocket_impl_v3 + | IO_socketAccept_impl_v3 + | IO_socketSend_impl_v3 + | IO_socketReceive_impl_v3 + | IO_kill_impl_v3 + | IO_delay_impl_v3 + | IO_stdHandle + | IO_process_call + | IO_process_start + | IO_process_kill + | IO_process_wait + | IO_process_exitCode + | MVar_new + | MVar_newEmpty_v2 + | MVar_take_impl_v3 + | MVar_tryTake + | MVar_put_impl_v3 + | MVar_tryPut_impl_v3 + | MVar_swap_impl_v3 + | MVar_isEmpty + | MVar_read_impl_v3 + | MVar_tryRead_impl_v3 + | Char_toText + | Text_repeat + | Text_reverse + | Text_toUppercase + | Text_toLowercase + | Text_toUtf8 + | Text_fromUtf8_impl_v3 + | Tls_ClientConfig_default + | Tls_ServerConfig_default + | Tls_ClientConfig_certificates_set + | Tls_ServerConfig_certificates_set + | TVar_new + | TVar_read + | TVar_write + | TVar_newIO + | TVar_readIO + | TVar_swap + | STM_retry + | Promise_new + | Promise_read + | Promise_tryRead + | Promise_write + | Tls_newClient_impl_v3 + | Tls_newServer_impl_v3 + | Tls_handshake_impl_v3 + | Tls_send_impl_v3 + | Tls_decodeCert_impl_v3 + | Tls_encodeCert + | Tls_decodePrivateKey + | Tls_encodePrivateKey + | Tls_receive_impl_v3 + | Tls_terminate_impl_v3 + | Code_validateLinks + | Code_dependencies + | Code_serialize + | Code_deserialize + | Code_display + | Value_dependencies + | Value_serialize + | Value_deserialize + | Crypto_HashAlgorithm_Sha3_512 + | Crypto_HashAlgorithm_Sha3_256 + | Crypto_HashAlgorithm_Sha2_512 + | Crypto_HashAlgorithm_Sha2_256 + | Crypto_HashAlgorithm_Sha1 + | Crypto_HashAlgorithm_Blake2b_512 + | Crypto_HashAlgorithm_Blake2b_256 + | Crypto_HashAlgorithm_Blake2s_256 + | Crypto_HashAlgorithm_Md5 + | Crypto_hashBytes + | Crypto_hmacBytes + | Crypto_hash + | Crypto_hmac + | Crypto_Ed25519_sign_impl + | Crypto_Ed25519_verify_impl + | Crypto_Rsa_sign_impl + | Crypto_Rsa_verify_impl + | Universal_murmurHash + | IO_randomBytes + | Bytes_zlib_compress + | Bytes_gzip_compress + | Bytes_zlib_decompress + | Bytes_gzip_decompress + | Bytes_toBase16 + | Bytes_toBase32 + | Bytes_toBase64 + | Bytes_toBase64UrlUnpadded + | Bytes_fromBase16 + | Bytes_fromBase32 + | Bytes_fromBase64 + | Bytes_fromBase64UrlUnpadded + | Bytes_decodeNat64be + | Bytes_decodeNat64le + | Bytes_decodeNat32be + | Bytes_decodeNat32le + | Bytes_decodeNat16be + | Bytes_decodeNat16le + | Bytes_encodeNat64be + | Bytes_encodeNat64le + | Bytes_encodeNat32be + | Bytes_encodeNat32le + | Bytes_encodeNat16be + | Bytes_encodeNat16le + | MutableArray_copyTo_force + | MutableByteArray_copyTo_force + | ImmutableArray_copyTo_force + | ImmutableArray_size + | MutableArray_size + | ImmutableByteArray_size + | MutableByteArray_size + | ImmutableByteArray_copyTo_force + | MutableArray_read + | MutableByteArray_read8 + | MutableByteArray_read16be + | MutableByteArray_read24be + | MutableByteArray_read32be + | MutableByteArray_read40be + | MutableByteArray_read64be + | MutableArray_write + | MutableByteArray_write8 + | MutableByteArray_write16be + | MutableByteArray_write32be + | MutableByteArray_write64be + | ImmutableArray_read + | ImmutableByteArray_read8 + | ImmutableByteArray_read16be + | ImmutableByteArray_read24be + | ImmutableByteArray_read32be + | ImmutableByteArray_read40be + | ImmutableByteArray_read64be + | MutableByteArray_freeze_force + | MutableArray_freeze_force + | MutableByteArray_freeze + | MutableArray_freeze + | MutableByteArray_length + | ImmutableByteArray_length + | IO_array + | IO_arrayOf + | IO_bytearray + | IO_bytearrayOf + | Scope_array + | Scope_arrayOf + | Scope_bytearray + | Scope_bytearrayOf + | Text_patterns_literal + | Text_patterns_digit + | Text_patterns_letter + | Text_patterns_space + | Text_patterns_punctuation + | Text_patterns_anyChar + | Text_patterns_eof + | Text_patterns_charRange + | Text_patterns_notCharRange + | Text_patterns_charIn + | Text_patterns_notCharIn + | Pattern_many + | Pattern_many_corrected + | Pattern_capture + | Pattern_captureAs + | Pattern_join + | Pattern_or + | Pattern_replicate + | Pattern_run + | Pattern_isMatch + | Char_Class_any + | Char_Class_not + | Char_Class_and + | Char_Class_or + | Char_Class_range + | Char_Class_anyOf + | Char_Class_alphanumeric + | Char_Class_upper + | Char_Class_lower + | Char_Class_whitespace + | Char_Class_control + | Char_Class_printable + | Char_Class_mark + | Char_Class_number + | Char_Class_punctuation + | Char_Class_symbol + | Char_Class_separator + | Char_Class_letter + | Char_Class_is + | Text_patterns_char + deriving (Show, Eq, Ord, Enum, Bounded) + +foreignFuncBuiltinName :: ForeignFunc -> Text +foreignFuncBuiltinName = \case + IO_UDP_clientSocket_impl_v1 -> "IO.UDP.clientSocket.impl.v1" + IO_UDP_UDPSocket_recv_impl_v1 -> "IO.UDP.UDPSocket.recv.impl.v1" + IO_UDP_UDPSocket_send_impl_v1 -> "IO.UDP.UDPSocket.send.impl.v1" + IO_UDP_UDPSocket_close_impl_v1 -> "IO.UDP.UDPSocket.close.impl.v1" + IO_UDP_ListenSocket_close_impl_v1 -> "IO.UDP.ListenSocket.close.impl.v1" + IO_UDP_UDPSocket_toText_impl_v1 -> "IO.UDP.UDPSocket.toText.impl.v1" + IO_UDP_serverSocket_impl_v1 -> "IO.UDP.serverSocket.impl.v1" + IO_UDP_ListenSocket_toText_impl_v1 -> "IO.UDP.ListenSocket.toText.impl.v1" + IO_UDP_ListenSocket_recvFrom_impl_v1 -> "IO.UDP.ListenSocket.recvFrom.impl.v1" + IO_UDP_ClientSockAddr_toText_v1 -> "IO.UDP.ClientSockAddr.toText.v1" + IO_UDP_ListenSocket_sendTo_impl_v1 -> "IO.UDP.ListenSocket.sendTo.impl.v1" + IO_openFile_impl_v3 -> "IO.openFile.impl.v3" + IO_closeFile_impl_v3 -> "IO.closeFile.impl.v3" + IO_isFileEOF_impl_v3 -> "IO.isFileEOF.impl.v3" + IO_isFileOpen_impl_v3 -> "IO.isFileOpen.impl.v3" + IO_getEcho_impl_v1 -> "IO.getEcho.impl.v1" + IO_ready_impl_v1 -> "IO.ready.impl.v1" + IO_getChar_impl_v1 -> "IO.getChar.impl.v1" + IO_isSeekable_impl_v3 -> "IO.isSeekable.impl.v3" + IO_seekHandle_impl_v3 -> "IO.seekHandle.impl.v3" + IO_handlePosition_impl_v3 -> "IO.handlePosition.impl.v3" + IO_getBuffering_impl_v3 -> "IO.getBuffering.impl.v3" + IO_setBuffering_impl_v3 -> "IO.setBuffering.impl.v3" + IO_setEcho_impl_v1 -> "IO.setEcho.impl.v1" + IO_getLine_impl_v1 -> "IO.getLine.impl.v1" + IO_getBytes_impl_v3 -> "IO.getBytes.impl.v3" + IO_getSomeBytes_impl_v1 -> "IO.getSomeBytes.impl.v1" + IO_putBytes_impl_v3 -> "IO.putBytes.impl.v3" + IO_systemTime_impl_v3 -> "IO.systemTime.impl.v3" + IO_systemTimeMicroseconds_v1 -> "IO.systemTimeMicroseconds.v1" + Clock_internals_monotonic_v1 -> "Clock.internals.monotonic.v1" + Clock_internals_realtime_v1 -> "Clock.internals.realtime.v1" + Clock_internals_processCPUTime_v1 -> "Clock.internals.processCPUTime.v1" + Clock_internals_threadCPUTime_v1 -> "Clock.internals.threadCPUTime.v1" + Clock_internals_sec_v1 -> "Clock.internals.sec.v1" + Clock_internals_nsec_v1 -> "Clock.internals.nsec.v1" + Clock_internals_systemTimeZone_v1 -> "Clock.internals.systemTimeZone.v1" + IO_getTempDirectory_impl_v3 -> "IO.getTempDirectory.impl.v3" + IO_createTempDirectory_impl_v3 -> "IO.createTempDirectory.impl.v3" + IO_getCurrentDirectory_impl_v3 -> "IO.getCurrentDirectory.impl.v3" + IO_setCurrentDirectory_impl_v3 -> "IO.setCurrentDirectory.impl.v3" + IO_fileExists_impl_v3 -> "IO.fileExists.impl.v3" + IO_getEnv_impl_v1 -> "IO.getEnv.impl.v1" + IO_getArgs_impl_v1 -> "IO.getArgs.impl.v1" + IO_isDirectory_impl_v3 -> "IO.isDirectory.impl.v3" + IO_createDirectory_impl_v3 -> "IO.createDirectory.impl.v3" + IO_removeDirectory_impl_v3 -> "IO.removeDirectory.impl.v3" + IO_renameDirectory_impl_v3 -> "IO.renameDirectory.impl.v3" + IO_directoryContents_impl_v3 -> "IO.directoryContents.impl.v3" + IO_removeFile_impl_v3 -> "IO.removeFile.impl.v3" + IO_renameFile_impl_v3 -> "IO.renameFile.impl.v3" + IO_getFileTimestamp_impl_v3 -> "IO.getFileTimestamp.impl.v3" + IO_getFileSize_impl_v3 -> "IO.getFileSize.impl.v3" + IO_serverSocket_impl_v3 -> "IO.serverSocket.impl.v3" + Socket_toText -> "Socket.toText" + Handle_toText -> "Handle.toText" + ThreadId_toText -> "ThreadId.toText" + IO_socketPort_impl_v3 -> "IO.socketPort.impl.v3" + IO_listen_impl_v3 -> "IO.listen.impl.v3" + IO_clientSocket_impl_v3 -> "IO.clientSocket.impl.v3" + IO_closeSocket_impl_v3 -> "IO.closeSocket.impl.v3" + IO_socketAccept_impl_v3 -> "IO.socketAccept.impl.v3" + IO_socketSend_impl_v3 -> "IO.socketSend.impl.v3" + IO_socketReceive_impl_v3 -> "IO.socketReceive.impl.v3" + IO_kill_impl_v3 -> "IO.kill.impl.v3" + IO_delay_impl_v3 -> "IO.delay.impl.v3" + IO_stdHandle -> "IO.stdHandle" + IO_process_call -> "IO.process.call" + IO_process_start -> "IO.process.start" + IO_process_kill -> "IO.process.kill" + IO_process_wait -> "IO.process.wait" + IO_process_exitCode -> "IO.process.exitCode" + MVar_new -> "MVar.new" + MVar_newEmpty_v2 -> "MVar.newEmpty.v2" + MVar_take_impl_v3 -> "MVar.take.impl.v3" + MVar_tryTake -> "MVar.tryTake" + MVar_put_impl_v3 -> "MVar.put.impl.v3" + MVar_tryPut_impl_v3 -> "MVar.tryPut.impl.v3" + MVar_swap_impl_v3 -> "MVar.swap.impl.v3" + MVar_isEmpty -> "MVar.isEmpty" + MVar_read_impl_v3 -> "MVar.read.impl.v3" + MVar_tryRead_impl_v3 -> "MVar.tryRead.impl.v3" + Char_toText -> "Char.toText" + Text_repeat -> "Text.repeat" + Text_reverse -> "Text.reverse" + Text_toUppercase -> "Text.toUppercase" + Text_toLowercase -> "Text.toLowercase" + Text_toUtf8 -> "Text.toUtf8" + Text_fromUtf8_impl_v3 -> "Text.fromUtf8.impl.v3" + Tls_ClientConfig_default -> "Tls.ClientConfig.default" + Tls_ServerConfig_default -> "Tls.ServerConfig.default" + Tls_ClientConfig_certificates_set -> "Tls.ClientConfig.certificates.set" + Tls_ServerConfig_certificates_set -> "Tls.ServerConfig.certificates.set" + TVar_new -> "TVar.new" + TVar_read -> "TVar.read" + TVar_write -> "TVar.write" + TVar_newIO -> "TVar.newIO" + TVar_readIO -> "TVar.readIO" + TVar_swap -> "TVar.swap" + STM_retry -> "STM.retry" + Promise_new -> "Promise.new" + Promise_read -> "Promise.read" + Promise_tryRead -> "Promise.tryRead" + Promise_write -> "Promise.write" + Tls_newClient_impl_v3 -> "Tls.newClient.impl.v3" + Tls_newServer_impl_v3 -> "Tls.newServer.impl.v3" + Tls_handshake_impl_v3 -> "Tls.handshake.impl.v3" + Tls_send_impl_v3 -> "Tls.send.impl.v3" + Tls_decodeCert_impl_v3 -> "Tls.decodeCert.impl.v3" + Tls_encodeCert -> "Tls.encodeCert" + Tls_decodePrivateKey -> "Tls.decodePrivateKey" + Tls_encodePrivateKey -> "Tls.encodePrivateKey" + Tls_receive_impl_v3 -> "Tls.receive.impl.v3" + Tls_terminate_impl_v3 -> "Tls.terminate.impl.v3" + Code_validateLinks -> "Code.validateLinks" + Code_dependencies -> "Code.dependencies" + Code_serialize -> "Code.serialize" + Code_deserialize -> "Code.deserialize" + Code_display -> "Code.display" + Value_dependencies -> "Value.dependencies" + Value_serialize -> "Value.serialize" + Value_deserialize -> "Value.deserialize" + Crypto_HashAlgorithm_Sha3_512 -> "crypto.HashAlgorithm.Sha3_512" + Crypto_HashAlgorithm_Sha3_256 -> "crypto.HashAlgorithm.Sha3_256" + Crypto_HashAlgorithm_Sha2_512 -> "crypto.HashAlgorithm.Sha2_512" + Crypto_HashAlgorithm_Sha2_256 -> "crypto.HashAlgorithm.Sha2_256" + Crypto_HashAlgorithm_Sha1 -> "crypto.HashAlgorithm.Sha1" + Crypto_HashAlgorithm_Blake2b_512 -> "crypto.HashAlgorithm.Blake2b_512" + Crypto_HashAlgorithm_Blake2b_256 -> "crypto.HashAlgorithm.Blake2b_256" + Crypto_HashAlgorithm_Blake2s_256 -> "crypto.HashAlgorithm.Blake2s_256" + Crypto_HashAlgorithm_Md5 -> "crypto.HashAlgorithm.Md5" + Crypto_hashBytes -> "crypto.hashBytes" + Crypto_hmacBytes -> "crypto.hmacBytes" + Crypto_hash -> "crypto.hash" + Crypto_hmac -> "crypto.hmac" + Crypto_Ed25519_sign_impl -> "crypto.Ed25519.sign.impl" + Crypto_Ed25519_verify_impl -> "crypto.Ed25519.verify.impl" + Crypto_Rsa_sign_impl -> "crypto.Rsa.sign.impl" + Crypto_Rsa_verify_impl -> "crypto.Rsa.verify.impl" + Universal_murmurHash -> "Universal.murmurHash" + IO_randomBytes -> "IO.randomBytes" + Bytes_zlib_compress -> "Bytes.zlib.compress" + Bytes_gzip_compress -> "Bytes.gzip.compress" + Bytes_zlib_decompress -> "Bytes.zlib.decompress" + Bytes_gzip_decompress -> "Bytes.gzip.decompress" + Bytes_toBase16 -> "Bytes.toBase16" + Bytes_toBase32 -> "Bytes.toBase32" + Bytes_toBase64 -> "Bytes.toBase64" + Bytes_toBase64UrlUnpadded -> "Bytes.toBase64UrlUnpadded" + Bytes_fromBase16 -> "Bytes.fromBase16" + Bytes_fromBase32 -> "Bytes.fromBase32" + Bytes_fromBase64 -> "Bytes.fromBase64" + Bytes_fromBase64UrlUnpadded -> "Bytes.fromBase64UrlUnpadded" + Bytes_decodeNat64be -> "Bytes.decodeNat64be" + Bytes_decodeNat64le -> "Bytes.decodeNat64le" + Bytes_decodeNat32be -> "Bytes.decodeNat32be" + Bytes_decodeNat32le -> "Bytes.decodeNat32le" + Bytes_decodeNat16be -> "Bytes.decodeNat16be" + Bytes_decodeNat16le -> "Bytes.decodeNat16le" + Bytes_encodeNat64be -> "Bytes.encodeNat64be" + Bytes_encodeNat64le -> "Bytes.encodeNat64le" + Bytes_encodeNat32be -> "Bytes.encodeNat32be" + Bytes_encodeNat32le -> "Bytes.encodeNat32le" + Bytes_encodeNat16be -> "Bytes.encodeNat16be" + Bytes_encodeNat16le -> "Bytes.encodeNat16le" + MutableArray_copyTo_force -> "MutableArray.copyTo!" + MutableByteArray_copyTo_force -> "MutableByteArray.copyTo!" + ImmutableArray_copyTo_force -> "ImmutableArray.copyTo!" + ImmutableArray_size -> "ImmutableArray.size" + MutableArray_size -> "MutableArray.size" + ImmutableByteArray_size -> "ImmutableByteArray.size" + MutableByteArray_size -> "MutableByteArray.size" + ImmutableByteArray_copyTo_force -> "ImmutableByteArray.copyTo!" + MutableArray_read -> "MutableArray.read" + MutableByteArray_read8 -> "MutableByteArray.read8" + MutableByteArray_read16be -> "MutableByteArray.read16be" + MutableByteArray_read24be -> "MutableByteArray.read24be" + MutableByteArray_read32be -> "MutableByteArray.read32be" + MutableByteArray_read40be -> "MutableByteArray.read40be" + MutableByteArray_read64be -> "MutableByteArray.read64be" + MutableArray_write -> "MutableArray.write" + MutableByteArray_write8 -> "MutableByteArray.write8" + MutableByteArray_write16be -> "MutableByteArray.write16be" + MutableByteArray_write32be -> "MutableByteArray.write32be" + MutableByteArray_write64be -> "MutableByteArray.write64be" + ImmutableArray_read -> "ImmutableArray.read" + ImmutableByteArray_read8 -> "ImmutableByteArray.read8" + ImmutableByteArray_read16be -> "ImmutableByteArray.read16be" + ImmutableByteArray_read24be -> "ImmutableByteArray.read24be" + ImmutableByteArray_read32be -> "ImmutableByteArray.read32be" + ImmutableByteArray_read40be -> "ImmutableByteArray.read40be" + ImmutableByteArray_read64be -> "ImmutableByteArray.read64be" + MutableByteArray_freeze_force -> "MutableByteArray.freeze!" + MutableArray_freeze_force -> "MutableArray.freeze!" + MutableByteArray_freeze -> "MutableByteArray.freeze" + MutableArray_freeze -> "MutableArray.freeze" + MutableByteArray_length -> "MutableByteArray.length" + ImmutableByteArray_length -> "ImmutableByteArray.length" + IO_array -> "IO.array" + IO_arrayOf -> "IO.arrayOf" + IO_bytearray -> "IO.bytearray" + IO_bytearrayOf -> "IO.bytearrayOf" + Scope_array -> "Scope.array" + Scope_arrayOf -> "Scope.arrayOf" + Scope_bytearray -> "Scope.bytearray" + Scope_bytearrayOf -> "Scope.bytearrayOf" + Text_patterns_literal -> "Text.patterns.literal" + Text_patterns_digit -> "Text.patterns.digit" + Text_patterns_letter -> "Text.patterns.letter" + Text_patterns_space -> "Text.patterns.space" + Text_patterns_punctuation -> "Text.patterns.punctuation" + Text_patterns_anyChar -> "Text.patterns.anyChar" + Text_patterns_eof -> "Text.patterns.eof" + Text_patterns_charRange -> "Text.patterns.charRange" + Text_patterns_notCharRange -> "Text.patterns.notCharRange" + Text_patterns_charIn -> "Text.patterns.charIn" + Text_patterns_notCharIn -> "Text.patterns.notCharIn" + Pattern_many -> "Pattern.many" + Pattern_many_corrected -> "Pattern.many.corrected" + Pattern_capture -> "Pattern.capture" + Pattern_captureAs -> "Pattern.captureAs" + Pattern_join -> "Pattern.join" + Pattern_or -> "Pattern.or" + Pattern_replicate -> "Pattern.replicate" + Pattern_run -> "Pattern.run" + Pattern_isMatch -> "Pattern.isMatch" + Char_Class_any -> "Char.Class.any" + Char_Class_not -> "Char.Class.not" + Char_Class_and -> "Char.Class.and" + Char_Class_or -> "Char.Class.or" + Char_Class_range -> "Char.Class.range" + Char_Class_anyOf -> "Char.Class.anyOf" + Char_Class_alphanumeric -> "Char.Class.alphanumeric" + Char_Class_upper -> "Char.Class.upper" + Char_Class_lower -> "Char.Class.lower" + Char_Class_whitespace -> "Char.Class.whitespace" + Char_Class_control -> "Char.Class.control" + Char_Class_printable -> "Char.Class.printable" + Char_Class_mark -> "Char.Class.mark" + Char_Class_number -> "Char.Class.number" + Char_Class_punctuation -> "Char.Class.punctuation" + Char_Class_symbol -> "Char.Class.symbol" + Char_Class_separator -> "Char.Class.separator" + Char_Class_letter -> "Char.Class.letter" + Char_Class_is -> "Char.Class.is" + Text_patterns_char -> "Text.patterns.char" diff --git a/unison-runtime/src/Unison/Runtime/Interface.hs b/unison-runtime/src/Unison/Runtime/Interface.hs index 33619b22b0..dfa54e01e4 100644 --- a/unison-runtime/src/Unison/Runtime/Interface.hs +++ b/unison-runtime/src/Unison/Runtime/Interface.hs @@ -109,17 +109,16 @@ import Unison.Runtime.Exception import Unison.Runtime.MCode ( Args (..), CombIx (..), - GCombs, GInstr (..), GSection (..), RCombs, RefNums (..), absurdCombs, - combDeps, combTypes, emitComb, emptyRNs, resolveCombs, + sanitizeCombsOfForeignFuncs, ) import Unison.Runtime.MCode.Serialize import Unison.Runtime.Machine @@ -1255,9 +1254,9 @@ tryM = hRE (PE _ e) = pure $ Just e hRE (BU _ _ _) = pure $ Just "impossible" -runStandalone :: StoredCache -> CombIx -> IO (Either (Pretty ColorText) ()) -runStandalone sc init = - restoreCache sc >>= executeMainComb init +runStandalone :: Bool -> StoredCache -> CombIx -> IO (Either (Pretty ColorText) ()) +runStandalone sandboxed sc init = + restoreCache sandboxed sc >>= executeMainComb init -- | A version of the Code Cache designed to be serialized to disk as -- standalone bytecode. @@ -1319,10 +1318,10 @@ tabulateErrors errs = : P.wrap "The following errors occured while decompiling:" : (listErrors errs) -restoreCache :: StoredCache -> IO CCache -restoreCache (SCache cs crs cacheableCombs trs ftm fty int rtm rty sbs) = do +restoreCache :: Bool -> StoredCache -> IO CCache +restoreCache sandboxed (SCache cs crs cacheableCombs trs ftm fty int rtm rty sbs) = do cc <- - CCache builtinForeigns False debugText + CCache sandboxed debugText <$> newTVarIO srcCombs <*> newTVarIO combs <*> newTVarIO (crs <> builtinTermBackref) @@ -1336,6 +1335,7 @@ restoreCache (SCache cs crs cacheableCombs trs ftm fty int rtm rty sbs) = do <*> newTVarIO (sbs <> baseSandboxInfo) let (unresolvedCacheableCombs, unresolvedNonCacheableCombs) = srcCombs + & sanitizeCombsOfForeignFuncs sandboxed sandboxedForeignFuncs & absurdCombs & EC.mapToList & foldMap @@ -1369,25 +1369,27 @@ restoreCache (SCache cs crs cacheableCombs trs ftm fty int rtm rty sbs) = do combs :: EnumMap Word64 (RCombs Val) combs = srcCombs + & sanitizeCombsOfForeignFuncs sandboxed sandboxedForeignFuncs & absurdCombs & resolveCombs Nothing traceNeeded :: - Word64 -> - EnumMap Word64 (GCombs clos comb) -> - IO (EnumMap Word64 (GCombs clos comb)) -traceNeeded init src = fmap (`withoutKeys` ks) $ go mempty init + Reference -> + Map Reference (SuperGroup Symbol) -> + IO (Map Reference (SuperGroup Symbol)) +traceNeeded init src = go mempty init where - ks = keysSet numberedTermLookup - go acc w - | hasKey w acc = pure acc - | Just co <- EC.lookup w src = - foldlM go (mapInsert w co acc) (foldMap combDeps co) - | otherwise = die $ "traceNeeded: unknown combinator: " ++ show w + go acc nx + | RF.isBuiltin nx = pure acc + | Map.member nx acc = pure acc + | Just co <- Map.lookup nx src = + foldlM go (Map.insert nx co acc) (groupTermLinks co) + | otherwise = + die $ "traceNeeded: unknown combinator: " ++ show nx buildSCache :: - EnumMap Word64 Combs -> EnumMap Word64 Reference -> + EnumMap Word64 Combs -> EnumSet Word64 -> EnumMap Word64 Reference -> Word64 -> @@ -1397,7 +1399,7 @@ buildSCache :: Map Reference Word64 -> Map Reference (Set Reference) -> StoredCache -buildSCache cs crsrc cacheableCombs trsrc ftm fty intsrc rtmsrc rtysrc sndbx = +buildSCache crsrc cssrc cacheableCombs trsrc ftm fty int rtmsrc rtysrc sndbx = SCache cs crs @@ -1405,19 +1407,31 @@ buildSCache cs crsrc cacheableCombs trsrc ftm fty intsrc rtmsrc rtysrc sndbx = trs ftm fty - (restrictTmR intsrc) - (restrictTmR rtmsrc) + int + rtm (restrictTyR rtysrc) (restrictTmR sndbx) where - combKeys = keysSet cs + termRefs = Map.keysSet int + + -- Retain just the Reference->Word mappings for needed code + rtm :: Map Reference Word64 + rtm = restrictTmR rtmsrc + + -- Retain numbers that correspond to the above termRefs + combKeys :: EnumSet Word64 + combKeys = foldMap setSingleton rtm + crs = restrictTmW crsrc - termRefs = foldMap Set.singleton crs + + cs :: EnumMap Word64 Combs + cs = restrictTmW cssrc typeKeys = setFromList $ (foldMap . foldMap) combTypes cs trs = restrictTyW trsrc typeRefs = foldMap Set.singleton trs + restrictTmW :: EnumMap Word64 a -> EnumMap Word64 a restrictTmW m = restrictKeys m combKeys restrictTmR :: Map Reference a -> Map Reference a restrictTmR m = Map.restrictKeys m termRefs @@ -1426,15 +1440,18 @@ buildSCache cs crsrc cacheableCombs trsrc ftm fty intsrc rtmsrc rtysrc sndbx = restrictTyR m = Map.restrictKeys m typeRefs standalone :: CCache -> Word64 -> IO StoredCache -standalone cc init = - buildSCache - <$> (readTVarIO (srcCombs cc) >>= traceNeeded init) - <*> readTVarIO (combRefs cc) - <*> readTVarIO (cacheableCombs cc) - <*> readTVarIO (tagRefs cc) - <*> readTVarIO (freshTm cc) - <*> readTVarIO (freshTy cc) - <*> readTVarIO (intermed cc) - <*> readTVarIO (refTm cc) - <*> readTVarIO (refTy cc) - <*> readTVarIO (sandbox cc) +standalone cc init = readTVarIO (combRefs cc) >>= \crs -> + case EC.lookup init crs of + Just rinit -> + buildSCache crs + <$> readTVarIO (srcCombs cc) + <*> readTVarIO (cacheableCombs cc) + <*> readTVarIO (tagRefs cc) + <*> readTVarIO (freshTm cc) + <*> readTVarIO (freshTy cc) + <*> (readTVarIO (intermed cc) >>= traceNeeded rinit) + <*> readTVarIO (refTm cc) + <*> readTVarIO (refTy cc) + <*> readTVarIO (sandbox cc) + Nothing -> + die $ "standalone: unknown combinator: " ++ show init diff --git a/unison-runtime/src/Unison/Runtime/MCode.hs b/unison-runtime/src/Unison/Runtime/MCode.hs index 80e28a1895..bc40170db8 100644 --- a/unison-runtime/src/Unison/Runtime/MCode.hs +++ b/unison-runtime/src/Unison/Runtime/MCode.hs @@ -38,6 +38,7 @@ module Unison.Runtime.MCode emitCombs, emitComb, resolveCombs, + sanitizeCombsOfForeignFuncs, absurdCombs, emptyRNs, argsToLists, @@ -59,7 +60,9 @@ import Data.Functor ((<&>)) import Data.Map.Strict qualified as M import Data.Primitive.PrimArray import Data.Primitive.PrimArray qualified as PA -import Data.Text as Text (unpack) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text qualified as Text import Data.Void (Void, absurd) import Data.Word (Word16, Word64) import GHC.Stack (HasCallStack) @@ -92,6 +95,7 @@ import Unison.Runtime.ANF pattern TVar, ) import Unison.Runtime.ANF qualified as ANF +import Unison.Runtime.Foreign.Function.Type (ForeignFunc (..), foreignFuncBuiltinName) import Unison.Util.EnumContainers as EC import Unison.Util.Text (Text) import Unison.Var (Var) @@ -253,6 +257,9 @@ import Unison.Var (Var) -- certain recursive, 'deep' handlers, since those can operate -- more like stateful code than control operators. +data Sandboxed = Tracked | Untracked + deriving (Show, Eq, Ord) + data Args' = Arg1 !Int | Arg2 !Int !Int @@ -278,6 +285,7 @@ argsToLists = \case VArgR i l -> take l [i ..] VArgN us -> primArrayToList us VArgV _ -> internalBug "argsToLists: DArgV" +{-# INLINEABLE argsToLists #-} countArgs :: Args -> Int countArgs ZArgs = 0 @@ -286,6 +294,7 @@ countArgs (VArg2 {}) = 2 countArgs (VArgR _ l) = l countArgs (VArgN us) = sizeofPrimArray us countArgs (VArgV {}) = internalBug "countArgs: DArgV" +{-# INLINEABLE countArgs #-} data UPrim1 = -- integral @@ -497,11 +506,10 @@ data GInstr comb | -- Use a check-and-set ticket to update a reference -- (ref stack index, ticket stack index, new value stack index) RefCAS !Int !Int !Int - | -- Call out to a Haskell function. This is considerably slower - -- for very simple operations, hence the primops. + | -- Call out to a Haskell function. ForeignCall !Bool -- catch exceptions - !Word64 -- FFI call + !ForeignFunc -- FFI call !Args -- arguments | -- Set the value of a dynamic reference SetDyn @@ -537,6 +545,8 @@ data GInstr comb Seq !Args | -- Force a delayed expression, catching any runtime exceptions involved TryForce !Int + | -- Attempted to use a builtin that was not allowed in the current sandboxing context. + SandboxingFailure !Text.Text -- The name of the builtin which failed was sandboxed. deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable) type Section = GSection CombIx @@ -1410,8 +1420,8 @@ emitPOp ANF.TFRC = \case -- to 'foreing function' calls, but there is a special case for the -- standard handle access function, because it does not yield an -- explicit error. -emitFOp :: ANF.FOp -> Args -> Instr -emitFOp fop = ForeignCall True (fromIntegral $ fromEnum fop) +emitFOp :: ForeignFunc -> Args -> Instr +emitFOp fop = ForeignCall True fop -- Helper functions for packing the variable argument representation -- into the indexes stored in prim op instructions @@ -1814,3 +1824,39 @@ prettyIns i = shows i prettyArgs :: Args -> ShowS prettyArgs ZArgs = showString "ZArgs" prettyArgs v = showParen True $ shows v + +-- | If running in a sandboxed environment, replace all restricted foreign functions with an error. +sanitizeCombsOfForeignFuncs :: Bool -> (Set ForeignFunc) -> EnumMap Word64 (EnumMap Word64 (GComb Void CombIx)) -> EnumMap Word64 (EnumMap Word64 (GComb Void CombIx)) +sanitizeCombsOfForeignFuncs sanitize sandboxedForeigns m + | sanitize = (fmap . fmap) (sanitizeComb sandboxedForeigns) m + | otherwise = m + +sanitizeComb :: Set ForeignFunc -> GComb Void CombIx -> GComb Void CombIx +sanitizeComb sandboxedForeigns = \case + Lam a b s -> Lam a b (sanitizeSection sandboxedForeigns s) + +-- | Crawl the source code and statically replace all sandboxed foreign funcs with an error. +sanitizeSection :: Set ForeignFunc -> GSection CombIx -> GSection CombIx +sanitizeSection sandboxedForeigns section = case section of + Ins (ForeignCall _ f as) nx + | Set.member f sandboxedForeigns -> Ins (SandboxingFailure (foreignFuncBuiltinName f)) (sanitizeSection sandboxedForeigns nx) + | otherwise -> Ins (ForeignCall True f as) (sanitizeSection sandboxedForeigns nx) + Ins i nx -> Ins i (sanitizeSection sandboxedForeigns nx) + App {} -> section + Call {} -> section + Jump {} -> section + Match i bs -> Match i (sanitizeBranches sandboxedForeigns bs) + Yield {} -> section + Let s i f b -> Let (sanitizeSection sandboxedForeigns s) i f (sanitizeSection sandboxedForeigns b) + Die {} -> section + Exit -> section + DMatch i j bs -> DMatch i j (sanitizeBranches sandboxedForeigns bs) + NMatch i j bs -> NMatch i j (sanitizeBranches sandboxedForeigns bs) + RMatch i s bs -> RMatch i (sanitizeSection sandboxedForeigns s) (fmap (sanitizeBranches sandboxedForeigns) bs) + +sanitizeBranches :: Set ForeignFunc -> GBranch CombIx -> GBranch CombIx +sanitizeBranches sandboxedForeigns = \case + Test1 i s d -> Test1 i (sanitizeSection sandboxedForeigns s) (sanitizeSection sandboxedForeigns d) + Test2 i s j t d -> Test2 i (sanitizeSection sandboxedForeigns s) j (sanitizeSection sandboxedForeigns t) (sanitizeSection sandboxedForeigns d) + TestW d m -> TestW (sanitizeSection sandboxedForeigns d) (fmap (sanitizeSection sandboxedForeigns) m) + TestT d m -> TestT (sanitizeSection sandboxedForeigns d) (fmap (sanitizeSection sandboxedForeigns) m) diff --git a/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs b/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs index 5d35608810..e6946403d9 100644 --- a/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs +++ b/unison-runtime/src/Unison/Runtime/MCode/Serialize.hs @@ -19,6 +19,7 @@ import Data.Word (Word64) import GHC.Exts (IsList (..)) import Unison.Runtime.ANF (PackedTag (..)) import Unison.Runtime.Array (PrimArray) +import Unison.Runtime.Foreign.Function.Type (ForeignFunc) import Unison.Runtime.MCode hiding (MatchT) import Unison.Runtime.Serialize import Unison.Util.Text qualified as Util.Text @@ -54,6 +55,13 @@ getComb = Lam <$> gInt <*> gInt <*> getSection CachedClosureT -> error "getComb: Unexpected serialized Cached Closure" +getMForeignFunc :: (MonadGet m) => m ForeignFunc +getMForeignFunc = do + toEnum <$> gInt + +putMForeignFunc :: (MonadPut m) => ForeignFunc -> m () +putMForeignFunc = pInt . fromEnum + data SectionT = AppT | CallT @@ -161,6 +169,7 @@ data InstrT | SeqT | TryForceT | RefCAST + | SandboxingFailureT instance Tag InstrT where tag2word UPrim1T = 0 @@ -181,6 +190,7 @@ instance Tag InstrT where tag2word SeqT = 15 tag2word TryForceT = 16 tag2word RefCAST = 17 + tag2word SandboxingFailureT = 18 word2tag 0 = pure UPrim1T word2tag 1 = pure UPrim2T @@ -200,6 +210,7 @@ instance Tag InstrT where word2tag 15 = pure SeqT word2tag 16 = pure TryForceT word2tag 17 = pure RefCAST + word2tag 18 = pure SandboxingFailureT word2tag n = unknownTag "InstrT" n putInstr :: (MonadPut m) => GInstr cix -> m () @@ -209,7 +220,7 @@ putInstr = \case (BPrim1 bp i) -> putTag BPrim1T *> putTag bp *> pInt i (BPrim2 bp i j) -> putTag BPrim2T *> putTag bp *> pInt i *> pInt j (RefCAS i j k) -> putTag RefCAST *> pInt i *> pInt j *> pInt k - (ForeignCall b w a) -> putTag ForeignCallT *> serialize b *> pWord w *> putArgs a + (ForeignCall b ff a) -> putTag ForeignCallT *> serialize b *> putMForeignFunc ff *> putArgs a (SetDyn w i) -> putTag SetDynT *> pWord w *> pInt i (Capture w) -> putTag CaptureT *> pWord w (Name r a) -> putTag NameT *> putRef r *> putArgs a @@ -222,6 +233,9 @@ putInstr = \case (Atomically i) -> putTag AtomicallyT *> pInt i (Seq a) -> putTag SeqT *> putArgs a (TryForce i) -> putTag TryForceT *> pInt i + (SandboxingFailure {}) -> + -- Sandboxing failures should only exist in code we're actively running, it shouldn't be serialized. + error "putInstr: Unexpected serialized Sandboxing Failure" getInstr :: (MonadGet m) => m Instr getInstr = @@ -231,7 +245,7 @@ getInstr = BPrim1T -> BPrim1 <$> getTag <*> gInt BPrim2T -> BPrim2 <$> getTag <*> gInt <*> gInt RefCAST -> RefCAS <$> gInt <*> gInt <*> gInt - ForeignCallT -> ForeignCall <$> deserialize <*> gWord <*> getArgs + ForeignCallT -> ForeignCall <$> deserialize <*> getMForeignFunc <*> getArgs SetDynT -> SetDyn <$> gWord <*> gInt CaptureT -> Capture <$> gWord NameT -> Name <$> getRef <*> getArgs @@ -244,6 +258,7 @@ getInstr = AtomicallyT -> Atomically <$> gInt SeqT -> Seq <$> getArgs TryForceT -> TryForce <$> gInt + SandboxingFailureT -> error "getInstr: Unexpected serialized Sandboxing Failure" data ArgsT = ZArgsT diff --git a/unison-runtime/src/Unison/Runtime/Machine.hs b/unison-runtime/src/Unison/Runtime/Machine.hs index bcb6ab0922..bfc7ab0c00 100644 --- a/unison-runtime/src/Unison/Runtime/Machine.hs +++ b/unison-runtime/src/Unison/Runtime/Machine.hs @@ -43,11 +43,11 @@ import Data.Set qualified as Set import Data.Text qualified as DTx import Data.Text.IO qualified as Tx import Data.Traversable -import GHC.Base (IO (..)) import GHC.Conc as STM (unsafeIOToSTM) import GHC.Stack import Unison.Builtin.Decls (exceptionRef, ioFailureRef) import Unison.Builtin.Decls qualified as Rf +import Unison.Builtin.Decls qualified as Ty import Unison.ConstructorReference qualified as CR import Unison.Prelude hiding (Text) import Unison.Reference @@ -72,10 +72,10 @@ import Unison.Runtime.ANF as ANF ) import Unison.Runtime.ANF qualified as ANF import Unison.Runtime.Array as PA -import Unison.Runtime.Builtin -import Unison.Runtime.Exception (RuntimeExn (..)) +import Unison.Runtime.Builtin hiding (unitValue) +import Unison.Runtime.Exception hiding (die) import Unison.Runtime.Foreign -import Unison.Runtime.Foreign.Function +import Unison.Runtime.Foreign.Function (foreignCall) import Unison.Runtime.MCode import Unison.Runtime.Stack import Unison.Runtime.TypeTags qualified as TT @@ -137,8 +137,7 @@ data Tracer -- code caching environment data CCache = CCache - { foreignFuncs :: EnumMap Word64 ForeignFunc, - sandboxed :: Bool, + { sandboxed :: Bool, tracer :: Bool -> Val -> Tracer, -- Combinators in their original form, where they're easier to serialize into SCache srcCombs :: TVar (EnumMap Word64 Combs), @@ -169,7 +168,7 @@ refNumTm cc r = baseCCache :: Bool -> IO CCache baseCCache sandboxed = do - CCache ffuncs sandboxed noTrace + CCache sandboxed noTrace <$> newTVarIO srcCombs <*> newTVarIO combs <*> newTVarIO builtinTermBackref @@ -183,7 +182,6 @@ baseCCache sandboxed = do <*> newTVarIO baseSandboxInfo where cacheableCombs = mempty - ffuncs | sandboxed = sandboxedForeigns | otherwise = builtinForeigns noTrace _ _ = NoTrace ftm = 1 + maximum builtinTermNumbering fty = 1 + maximum builtinTypeNumbering @@ -198,6 +196,7 @@ baseCCache sandboxed = do combs :: EnumMap Word64 MCombs combs = srcCombs + & sanitizeCombsOfForeignFuncs sandboxed sandboxedForeignFuncs & absurdCombs & resolveCombs Nothing @@ -209,7 +208,7 @@ infos ctx s = putStrLn $ ctx ++ ": " ++ s -- Entry point for evaluating a section eval0 :: CCache -> ActiveThreads -> MSection -> IO () -eval0 !env !activeThreads !co = do +eval0 env !activeThreads !co = do stk <- alloc cmbs <- readTVarIO $ combs env (denv, k) <- @@ -248,7 +247,7 @@ apply0 :: ActiveThreads -> Word64 -> IO () -apply0 !callback !env !threadTracker !i = do +apply0 !callback env !threadTracker !i = do stk <- alloc cmbrs <- readTVarIO $ combRefs env cmbs <- readTVarIO $ combs env @@ -281,8 +280,13 @@ apply1 callback env threadTracker clo = do where k0 = CB $ Hook (\stk -> callback $ packXStack stk) -unitValue :: Closure -unitValue = Enum Rf.unitRef TT.unitTag +unitValue :: Val +unitValue = BoxedVal $ unitClosure +{-# NOINLINE unitValue #-} + +unitClosure :: Closure +unitClosure = Enum Ty.unitRef (PackedTag 0) +{-# NOINLINE unitClosure #-} litToVal :: MLit -> Val litToVal = \case @@ -328,33 +332,33 @@ exec :: IO (DEnv, Stack, K) {- ORMOLU_DISABLE -} #ifdef STACK_CHECK -exec !_ !_ !_ !stk !_ !_ instr +exec _ !_ !_ !stk !_ !_ instr | debugger stk "exec" instr = undefined #endif {- ORMOLU_ENABLE -} -exec !_ !denv !_activeThreads !stk !k _ (Info tx) = do +exec _ !denv !_activeThreads !stk !k _ (Info tx) = do info tx stk info tx k pure (denv, stk, k) -exec !env !denv !_activeThreads !stk !k _ (Name r args) = do +exec env !denv !_activeThreads !stk !k _ (Name r args) = do v <- resolve env denv stk r stk <- name stk args v pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (SetDyn p i) = do +exec _ !denv !_activeThreads !stk !k _ (SetDyn p i) = do val <- peekOff stk i pure (EC.mapInsert p val denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (Capture p) = do +exec _ !denv !_activeThreads !stk !k _ (Capture p) = do (cap, denv, stk, k) <- splitCont denv stk k p stk <- bump stk poke stk cap pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (UPrim1 op i) = do +exec _ !denv !_activeThreads !stk !k _ (UPrim1 op i) = do stk <- uprim1 stk op i pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (UPrim2 op i j) = do +exec _ !denv !_activeThreads !stk !k _ (UPrim2 op i j) = do stk <- uprim2 stk op i j pure (denv, stk, k) -exec !env !denv !_activeThreads !stk !k _ (BPrim1 MISS i) +exec env !denv !_activeThreads !stk !k _ (BPrim1 MISS i) | sandboxed env = die "attempted to use sandboxed operation: isMissing" | otherwise = do clink <- bpeekOff stk i @@ -365,7 +369,7 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim1 MISS i) stk <- bump stk pokeBool stk $ (link `M.member` m) pure (denv, stk, k) -exec !env !denv !_activeThreads !stk !k _ (BPrim1 CACH i) +exec env !denv !_activeThreads !stk !k _ (BPrim1 CACH i) | sandboxed env = die "attempted to use sandboxed operation: cache" | otherwise = do arg <- peekOffS stk i @@ -376,7 +380,7 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim1 CACH i) stk (Sq.fromList $ boxedVal . Foreign . Wrap Rf.termLinkRef . Ref <$> unknown) pure (denv, stk, k) -exec !env !denv !_activeThreads !stk !k _ (BPrim1 CVLD i) +exec env !denv !_activeThreads !stk !k _ (BPrim1 CVLD i) | sandboxed env = die "attempted to use sandboxed operation: validate" | otherwise = do arg <- peekOffS stk i @@ -394,7 +398,7 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim1 CVLD i) stk <- bump stk pokeTag stk 1 pure (denv, stk, k) -exec !env !denv !_activeThreads !stk !k _ (BPrim1 LKUP i) +exec env !denv !_activeThreads !stk !k _ (BPrim1 LKUP i) | sandboxed env = die "attempted to use sandboxed operation: lookup" | otherwise = do clink <- bpeekOff stk i @@ -423,7 +427,7 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim1 LKUP i) stk <- bump stk stk <$ pokeTag stk 1 pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (BPrim1 TLTT i) = do +exec _ !denv !_activeThreads !stk !k _ (BPrim1 TLTT i) = do clink <- bpeekOff stk i let shortHash = case unwrapForeign $ marshalToForeign clink of Ref r -> toShortHash r @@ -432,7 +436,7 @@ exec !_ !denv !_activeThreads !stk !k _ (BPrim1 TLTT i) = do stk <- bump stk pokeBi stk sh pure (denv, stk, k) -exec !env !denv !_activeThreads !stk !k _ (BPrim1 LOAD i) +exec env !denv !_activeThreads !stk !k _ (BPrim1 LOAD i) | sandboxed env = die "attempted to use sandboxed operation: load" | otherwise = do v <- peekOffBi stk i @@ -447,13 +451,13 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim1 LOAD i) pokeOff stk 1 x pokeTag stk 1 pure (denv, stk, k) -exec !env !denv !_activeThreads !stk !k _ (BPrim1 VALU i) = do +exec env !denv !_activeThreads !stk !k _ (BPrim1 VALU i) = do m <- readTVarIO (tagRefs env) c <- peekOff stk i stk <- bump stk pokeBi stk =<< reflectValue m c pure (denv, stk, k) -exec !env !denv !_activeThreads !stk !k _ (BPrim1 DBTX i) +exec env !denv !_activeThreads !stk !k _ (BPrim1 DBTX i) | sandboxed env = die "attempted to use sandboxed operation: Debug.toText" | otherwise = do @@ -470,7 +474,7 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim1 DBTX i) stk <- bump stk stk <$ pokeTag stk 2 pure (denv, stk, k) -exec !env !denv !_activeThreads !stk !k _ (BPrim1 SDBL i) +exec env !denv !_activeThreads !stk !k _ (BPrim1 SDBL i) | sandboxed env = die "attempted to use sandboxed operation: sandboxLinks" | otherwise = do @@ -478,10 +482,10 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim1 SDBL i) stk <- bump stk pokeS stk . encodeSandboxListResult =<< sandboxList env tl pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (BPrim1 op i) = do - stk <- bprim1 stk op i +exec env !denv !_activeThreads !stk !k _ (BPrim1 op i) = do + stk <- bprim1 env stk op i pure (denv, stk, k) -exec !env !denv !_activeThreads !stk !k _ (BPrim2 SDBX i j) = do +exec env !denv !_activeThreads !stk !k _ (BPrim2 SDBX i j) = do s <- peekOffS stk i c <- bpeekOff stk j l <- decodeSandboxArgument s @@ -489,7 +493,7 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim2 SDBX i j) = do stk <- bump stk pokeBool stk $ b pure (denv, stk, k) -exec !env !denv !_activeThreads !stk !k _ (BPrim2 SDBV i j) +exec env !denv !_activeThreads !stk !k _ (BPrim2 SDBV i j) | sandboxed env = die "attempted to use sandboxed operation: Value.validateSandboxed" | otherwise = do @@ -500,36 +504,36 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim2 SDBV i j) stk <- bump stk bpoke stk $ encodeSandboxResult res pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (BPrim2 EQLU i j) = do +exec _ !denv !_activeThreads !stk !k _ (BPrim2 EQLU i j) = do x <- peekOff stk i y <- peekOff stk j stk <- bump stk pokeBool stk $ universalEq (==) x y pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (BPrim2 LEQU i j) = do +exec _ !denv !_activeThreads !stk !k _ (BPrim2 LEQU i j) = do x <- peekOff stk i y <- peekOff stk j stk <- bump stk pokeBool stk $ (universalCompare compare x y) /= GT pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (BPrim2 LESU i j) = do +exec _ !denv !_activeThreads !stk !k _ (BPrim2 LESU i j) = do x <- peekOff stk i y <- peekOff stk j stk <- bump stk pokeBool stk $ (universalCompare compare x y) == LT pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (BPrim2 CMPU i j) = do +exec _ !denv !_activeThreads !stk !k _ (BPrim2 CMPU i j) = do x <- peekOff stk i y <- peekOff stk j stk <- bump stk pokeI stk . pred . fromEnum $ universalCompare compare x y pure (denv, stk, k) -exec !_ !_ !_activeThreads !stk !k r (BPrim2 THRO i j) = do +exec _ !_ !_activeThreads !stk !k r (BPrim2 THRO i j) = do name <- peekOffBi @Util.Text.Text stk i x <- peekOff stk j () <- throwIO (BU (traceK r k) (Util.Text.toText name) x) error "throwIO should never return" -exec !env !denv !_activeThreads !stk !k _ (BPrim2 TRCE i j) +exec env !denv !_activeThreads !stk !k _ (BPrim2 TRCE i j) | sandboxed env = die "attempted to use sandboxed operation: trace" | otherwise = do tx <- peekOffBi stk i @@ -548,66 +552,63 @@ exec !env !denv !_activeThreads !stk !k _ (BPrim2 TRCE i j) putStrLn "partial decompilation:\n" putStrLn pre pure (denv, stk, k) -exec !_ !denv !_trackThreads !stk !k _ (BPrim2 op i j) = do +exec _ !denv !_trackThreads !stk !k _ (BPrim2 op i j) = do stk <- bprim2 stk op i j pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (RefCAS refI ticketI valI) = do - (ref :: IORef Val) <- peekOffBi stk refI - -- Note that the CAS machinery is extremely fussy w/r to whether things are forced because it - -- uses unsafe pointer equality. The only way we've gotten it to work as expected is with liberal - -- forcing of the values and tickets. - !(ticket :: Atomic.Ticket Val) <- peekOffBi stk ticketI - v <- peekOff stk valI - (r, _) <- Atomic.casIORef ref ticket v - stk <- bump stk - pokeBool stk r - pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (Pack r t args) = do +exec env !denv !_activeThreads !stk !k _ (RefCAS refI ticketI valI) + | sandboxed env = die "attempted to use sandboxed operation: Ref.cas" + | otherwise = do + (ref :: IORef Val) <- peekOffBi stk refI + -- Note that the CAS machinery is extremely fussy w/r to whether things are forced because it + -- uses unsafe pointer equality. The only way we've gotten it to work as expected is with liberal + -- forcing of the values and tickets. + !(ticket :: Atomic.Ticket Val) <- peekOffBi stk ticketI + v <- peekOff stk valI + (r, _) <- Atomic.casIORef ref ticket v + stk <- bump stk + pokeBool stk r + pure (denv, stk, k) +exec _ !denv !_activeThreads !stk !k _ (Pack r t args) = do clo <- buildData stk r t args stk <- bump stk bpoke stk clo pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (Print i) = do +exec _ !denv !_activeThreads !stk !k _ (Print i) = do t <- peekOffBi stk i Tx.putStrLn (Util.Text.toText t) pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (Lit ml) = do +exec _ !denv !_activeThreads !stk !k _ (Lit ml) = do stk <- bump stk poke stk $ litToVal ml pure (denv, stk, k) -exec !_ !denv !_activeThreads !stk !k _ (Reset ps) = do +exec _ !denv !_activeThreads !stk !k _ (Reset ps) = do (stk, a) <- saveArgs stk pure (denv, stk, Mark a ps clos k) where clos = EC.restrictKeys denv ps -exec !_ !denv !_activeThreads !stk !k _ (Seq as) = do +exec _ !denv !_activeThreads !stk !k _ (Seq as) = do l <- closureArgs stk as stk <- bump stk pokeS stk $ Sq.fromList l pure (denv, stk, k) -exec !env !denv !_activeThreads !stk !k _ (ForeignCall _ w args) - | Just (FF arg res ev) <- EC.lookup w (foreignFuncs env) = do - let xStack = unpackXStack stk - r <- arg (unpackXStack stk) args >>= ev - IO $ \s -> case res xStack r s of - (# s, xstk #) -> (# s, (denv, packXStack xstk, k) #) - | otherwise = - die $ "reference to unknown foreign function: " ++ show w -exec !env !denv !activeThreads !stk !k _ (Fork i) +exec _env !denv !_activeThreads !stk !k _ (ForeignCall _ func args) = do + stk <- xStackIOToIO $ foreignCall func args (unpackXStack stk) + pure (denv, stk, k) +exec env !denv !activeThreads !stk !k _ (Fork i) | sandboxed env = die "attempted to use sandboxed operation: fork" | otherwise = do tid <- forkEval env activeThreads =<< peekOff stk i stk <- bump stk bpoke stk . Foreign . Wrap Rf.threadIdRef $ tid pure (denv, stk, k) -exec !env !denv !activeThreads !stk !k _ (Atomically i) +exec env !denv !activeThreads !stk !k _ (Atomically i) | sandboxed env = die $ "attempted to use sandboxed operation: atomically" | otherwise = do v <- peekOff stk i stk <- bump stk atomicEval env activeThreads (poke stk) v pure (denv, stk, k) -exec !env !denv !activeThreads !stk !k _ (TryForce i) +exec env !denv !activeThreads !stk !k _ (TryForce i) | sandboxed env = die $ "attempted to use sandboxed operation: tryForce" | otherwise = do v <- peekOff stk i @@ -615,6 +616,8 @@ exec !env !denv !activeThreads !stk !k _ (TryForce i) ev <- Control.Exception.try $ nestEval env activeThreads (poke stk) v stk <- encodeExn stk ev pure (denv, stk, k) +exec !_ !_ !_ !_ !_ _ (SandboxingFailure t) = do + die $ "Attempted to use disallowed builtin in sandboxed environment: " <> DTx.unpack t {-# INLINE exec #-} encodeExn :: @@ -640,22 +643,22 @@ encodeExn stk exc = do disp e = Util.Text.pack $ show e (link, msg, extra) | Just (ioe :: IOException) <- fromException exn = - (Rf.ioFailureRef, disp ioe, boxedVal unitValue) + (Rf.ioFailureRef, disp ioe, unitValue) | Just re <- fromException exn = case re of PE _stk msg -> - (Rf.runtimeFailureRef, Util.Text.pack $ toPlainUnbroken msg, boxedVal unitValue) + (Rf.runtimeFailureRef, Util.Text.pack $ toPlainUnbroken msg, unitValue) BU _ tx val -> (Rf.runtimeFailureRef, Util.Text.fromText tx, val) | Just (ae :: ArithException) <- fromException exn = - (Rf.arithmeticFailureRef, disp ae, boxedVal unitValue) + (Rf.arithmeticFailureRef, disp ae, unitValue) | Just (nae :: NestedAtomically) <- fromException exn = - (Rf.stmFailureRef, disp nae, boxedVal unitValue) + (Rf.stmFailureRef, disp nae, unitValue) | Just (be :: BlockedIndefinitelyOnSTM) <- fromException exn = - (Rf.stmFailureRef, disp be, boxedVal unitValue) + (Rf.stmFailureRef, disp be, unitValue) | Just (be :: BlockedIndefinitelyOnMVar) <- fromException exn = - (Rf.ioFailureRef, disp be, boxedVal unitValue) + (Rf.ioFailureRef, disp be, unitValue) | Just (ie :: AsyncException) <- fromException exn = - (Rf.threadKilledFailureRef, disp ie, boxedVal unitValue) - | otherwise = (Rf.miscFailureRef, disp exn, boxedVal unitValue) + (Rf.threadKilledFailureRef, disp ie, unitValue) + | otherwise = (Rf.miscFailureRef, disp exn, unitValue) -- | Evaluate a section eval :: @@ -669,24 +672,24 @@ eval :: IO () {- ORMOLU_DISABLE -} #ifdef STACK_CHECK -eval !_ !_ !_ !stk !_ !_ section +eval _ !_ !_ !stk !_ !_ section | debugger stk "eval" section = undefined #endif {- ORMOLU_ENABLE -} -eval !env !denv !activeThreads !stk !k r (Match i (TestT df cs)) = do +eval env !denv !activeThreads !stk !k r (Match i (TestT df cs)) = do t <- peekOffBi stk i eval env denv activeThreads stk k r $ selectTextBranch t df cs -eval !env !denv !activeThreads !stk !k r (Match i br) = do +eval env !denv !activeThreads !stk !k r (Match i br) = do n <- peekOffN stk i eval env denv activeThreads stk k r $ selectBranch n br -eval !env !denv !activeThreads !stk !k r (DMatch mr i br) = do +eval env !denv !activeThreads !stk !k r (DMatch mr i br) = do (t, stk) <- dumpDataNoTag mr stk =<< peekOff stk i eval env denv activeThreads stk k r $ selectBranch (maskTags t) br -eval !env !denv !activeThreads !stk !k r (NMatch _mr i br) = do +eval env !denv !activeThreads !stk !k r (NMatch _mr i br) = do n <- peekOffN stk i eval env denv activeThreads stk k r $ selectBranch n br -eval !env !denv !activeThreads !stk !k r (RMatch i pu br) = do +eval env !denv !activeThreads !stk !k r (RMatch i pu br) = do (t, stk) <- dumpDataNoTag Nothing stk =<< peekOff stk i if t == PackedTag 0 then eval env denv activeThreads stk k r pu @@ -695,7 +698,7 @@ eval !env !denv !activeThreads !stk !k r (RMatch i pu br) = do | Just ebs <- EC.lookup e br -> eval env denv activeThreads stk k r $ selectBranch t ebs | otherwise -> unhandledAbilityRequest -eval !env !denv !activeThreads !stk !k _ (Yield args) +eval env !denv !activeThreads !stk !k _ (Yield args) | asize stk > 0, VArg1 i <- args = peekOff stk i >>= apply env denv activeThreads stk k False ZArgs @@ -703,14 +706,14 @@ eval !env !denv !activeThreads !stk !k _ (Yield args) stk <- moveArgs stk args stk <- frameArgs stk yield env denv activeThreads stk k -eval !env !denv !activeThreads !stk !k _ (App ck r args) = +eval env !denv !activeThreads !stk !k _ (App ck r args) = resolve env denv stk r >>= apply env denv activeThreads stk k ck args -eval !env !denv !activeThreads !stk !k _ (Call ck combIx rcomb args) = +eval env !denv !activeThreads !stk !k _ (Call ck combIx rcomb args) = enter env denv activeThreads stk k (combRef combIx) ck args rcomb -eval !env !denv !activeThreads !stk !k _ (Jump i args) = +eval env !denv !activeThreads !stk !k _ (Jump i args) = bpeekOff stk i >>= jump env denv activeThreads stk k args -eval !env !denv !activeThreads !stk !k r (Let nw cix f sect) = do +eval env !denv !activeThreads !stk !k r (Let nw cix f sect) = do (stk, fsz, asz) <- saveFrame stk eval env @@ -720,11 +723,11 @@ eval !env !denv !activeThreads !stk !k r (Let nw cix f sect) = do (Push fsz asz cix f sect k) r nw -eval !env !denv !activeThreads !stk !k r (Ins i nx) = do +eval env !denv !activeThreads !stk !k r (Ins i nx) = do (denv, stk, k) <- exec env denv activeThreads stk k r i eval env denv activeThreads stk k r nx -eval !_ !_ !_ !_activeThreads !_ _ Exit = pure () -eval !_ !_ !_ !_activeThreads !_ _ (Die s) = die s +eval _ !_ !_ !_activeThreads !_ _ Exit = pure () +eval _ !_ !_ !_activeThreads !_ _ (Die s) = die s {-# NOINLINE eval #-} unhandledAbilityRequest :: (HasCallStack) => IO a @@ -779,7 +782,7 @@ enter :: Args -> MComb -> IO () -enter !env !denv !activeThreads !stk !k !cref !sck !args = \case +enter env !denv !activeThreads !stk !k !cref !sck !args = \case (RComb (Lam a f entry)) -> do -- check for stack check _skip_ stk <- if sck then pure stk else ensure stk f @@ -817,11 +820,11 @@ apply :: IO () {- ORMOLU_DISABLE -} #ifdef STACK_CHECK -apply !_env !_denv !_activeThreads !stk !_k !_ck !args !val +apply _env !_denv !_activeThreads !stk !_k !_ck !args !val | debugger stk "apply" (args, val) = undefined #endif {- ORMOLU_ENABLE -} -apply !env !denv !activeThreads !stk !k !ck !args !val = +apply env !denv !activeThreads !stk !k !ck !args !val = case val of BoxedVal (PAp cix@(CIx combRef _ _) comb seg) -> case comb of @@ -862,7 +865,7 @@ jump :: Args -> Closure -> IO () -jump !env !denv !activeThreads !stk !k !args clo = case clo of +jump env !denv !activeThreads !stk !k !args clo = case clo of Captured sk0 a seg -> do let (p, sk) = adjust sk0 seg <- closeArgs K stk seg args @@ -894,7 +897,7 @@ repush :: K -> K -> IO () -repush !env !activeThreads !stk = go +repush env !activeThreads !stk = go where go !denv KE !k = yield env denv activeThreads stk k go !denv (Mark a ps cs sk) !k = go denv' sk $ Mark a ps cs' k @@ -1511,36 +1514,37 @@ uprim2 !stk IORB !i !j = do {-# INLINE uprim2 #-} bprim1 :: + CCache -> Stack -> BPrim1 -> Int -> IO Stack -bprim1 !stk SIZT i = do +bprim1 !_env !stk SIZT i = do t <- peekOffBi stk i stk <- bump stk unsafePokeIasN stk $ Util.Text.size t pure stk -bprim1 !stk SIZS i = do +bprim1 !_env !stk SIZS i = do s <- peekOffS stk i stk <- bump stk unsafePokeIasN stk $ Sq.length s pure stk -bprim1 !stk ITOT i = do +bprim1 !_env !stk ITOT i = do n <- upeekOff stk i stk <- bump stk pokeBi stk . Util.Text.pack $ show n pure stk -bprim1 !stk NTOT i = do +bprim1 !_env !stk NTOT i = do n <- peekOffN stk i stk <- bump stk pokeBi stk . Util.Text.pack $ show n pure stk -bprim1 !stk FTOT i = do +bprim1 !_env !stk FTOT i = do f <- peekOffD stk i stk <- bump stk pokeBi stk . Util.Text.pack $ show f pure stk -bprim1 !stk USNC i = +bprim1 !_env !stk USNC i = peekOffBi stk i >>= \t -> case Util.Text.unsnoc t of Nothing -> do stk <- bump stk @@ -1552,7 +1556,7 @@ bprim1 !stk USNC i = pokeOffBi stk 1 t -- remaining text pokeTag stk 1 -- 'Just' tag pure stk -bprim1 !stk UCNS i = +bprim1 !_env !stk UCNS i = peekOffBi stk i >>= \t -> case Util.Text.uncons t of Nothing -> do stk <- bump stk @@ -1564,7 +1568,7 @@ bprim1 !stk UCNS i = pokeOffC stk 1 $ c -- char value pokeTag stk 1 -- 'Just' tag pure stk -bprim1 !stk TTOI i = +bprim1 !_env !stk TTOI i = peekOffBi stk i >>= \t -> case readm $ Util.Text.unpack t of Just n | fromIntegral (minBound :: Int) <= n, @@ -1580,7 +1584,7 @@ bprim1 !stk TTOI i = where readm ('+' : s) = readMaybe s readm s = readMaybe s -bprim1 !stk TTON i = +bprim1 !_env !stk TTON i = peekOffBi stk i >>= \t -> case readMaybe $ Util.Text.unpack t of Just n | 0 <= n, @@ -1593,7 +1597,7 @@ bprim1 !stk TTON i = stk <- bump stk pokeTag stk 0 pure stk -bprim1 !stk TTOF i = +bprim1 !_env !stk TTOF i = peekOffBi stk i >>= \t -> case readMaybe $ Util.Text.unpack t of Nothing -> do stk <- bump stk @@ -1604,7 +1608,7 @@ bprim1 !stk TTOF i = pokeTag stk 1 pokeOffD stk 1 f pure stk -bprim1 !stk VWLS i = +bprim1 !_env !stk VWLS i = peekOffS stk i >>= \case Sq.Empty -> do stk <- bump stk @@ -1616,7 +1620,7 @@ bprim1 !stk VWLS i = pokeOff stk 1 x -- head pokeTag stk 1 -- ':<|' tag pure stk -bprim1 !stk VWRS i = +bprim1 !_env !stk VWRS i = peekOffS stk i >>= \case Sq.Empty -> do stk <- bump stk @@ -1628,7 +1632,7 @@ bprim1 !stk VWRS i = pokeOffS stk 1 xs -- remaining seq pokeTag stk 1 -- ':|>' tag pure stk -bprim1 !stk PAKT i = do +bprim1 !_env !stk PAKT i = do s <- peekOffS stk i stk <- bump stk pokeBi stk . Util.Text.pack . toList $ val2char <$> s @@ -1637,7 +1641,7 @@ bprim1 !stk PAKT i = do val2char :: Val -> Char val2char (CharVal c) = c val2char c = error $ "pack text: non-character closure: " ++ show c -bprim1 !stk UPKT i = do +bprim1 !_env !stk UPKT i = do t <- peekOffBi stk i stk <- bump stk pokeS stk @@ -1646,7 +1650,7 @@ bprim1 !stk UPKT i = do . Util.Text.unpack $ t pure stk -bprim1 !stk PAKB i = do +bprim1 !_env !stk PAKB i = do s <- peekOffS stk i stk <- bump stk pokeBi stk . By.fromWord8s . fmap val2w8 $ toList s @@ -1656,18 +1660,18 @@ bprim1 !stk PAKB i = do val2w8 :: Val -> Word8 val2w8 (NatVal n) = toEnum . fromEnum $ n val2w8 c = error $ "pack bytes: non-natural closure: " ++ show c -bprim1 !stk UPKB i = do +bprim1 !_env !stk UPKB i = do b <- peekOffBi stk i stk <- bump stk pokeS stk . Sq.fromList . fmap (NatVal . toEnum @Word64 . fromEnum @Word8) $ By.toWord8s b pure stk -bprim1 !stk SIZB i = do +bprim1 !_env !stk SIZB i = do b <- peekOffBi stk i stk <- bump stk unsafePokeIasN stk $ By.size b pure stk -bprim1 !stk FLTB i = do +bprim1 !_env !stk FLTB i = do b <- peekOffBi stk i stk <- bump stk pokeBi stk $ By.flatten b @@ -1680,13 +1684,13 @@ bprim1 !stk FLTB i = do -- [1] https://hackage.haskell.org/package/base-4.17.0.0/docs/Data-IORef.html#g:2 -- [2] https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L286 -- [3] https://github.com/ghc/ghc/blob/master/compiler/GHC/StgToCmm/Prim.hs#L298 -bprim1 !stk REFR i = do +bprim1 !_env !stk REFR i = do (ref :: IORef Val) <- peekOffBi stk i v <- IORef.readIORef ref stk <- bump stk poke stk v pure stk -bprim1 !stk REFN i = do +bprim1 !_env !stk REFN i = do -- Note that the CAS machinery is extremely fussy w/r to whether things are forced because it -- uses unsafe pointer equality. The only way we've gotten it to work as expected is with liberal -- forcing of the values and tickets. @@ -1695,13 +1699,15 @@ bprim1 !stk REFN i = do stk <- bump stk pokeBi stk ref pure stk -bprim1 !stk RRFC i = do - (ref :: IORef Val) <- peekOffBi stk i - ticket <- Atomic.readForCAS ref - stk <- bump stk - pokeBi stk ticket - pure stk -bprim1 !stk TIKR i = do +bprim1 !env !stk RRFC i + | sandboxed env = die "attempted to use sandboxed operation: Ref.readForCAS" + | otherwise = do + (ref :: IORef Val) <- peekOffBi stk i + ticket <- Atomic.readForCAS ref + stk <- bump stk + pokeBi stk ticket + pure stk +bprim1 !_env !stk TIKR i = do (t :: Atomic.Ticket Val) <- peekOffBi stk i stk <- bump stk let v = Atomic.peekTicket t @@ -1709,15 +1715,15 @@ bprim1 !stk TIKR i = do pure stk -- impossible -bprim1 !stk MISS _ = pure stk -bprim1 !stk CACH _ = pure stk -bprim1 !stk LKUP _ = pure stk -bprim1 !stk CVLD _ = pure stk -bprim1 !stk TLTT _ = pure stk -bprim1 !stk LOAD _ = pure stk -bprim1 !stk VALU _ = pure stk -bprim1 !stk DBTX _ = pure stk -bprim1 !stk SDBL _ = pure stk +bprim1 !_env !stk MISS _ = pure stk +bprim1 !_env !stk CACH _ = pure stk +bprim1 !_env !stk LKUP _ = pure stk +bprim1 !_env !stk CVLD _ = pure stk +bprim1 !_env !stk TLTT _ = pure stk +bprim1 !_env !stk LOAD _ = pure stk +bprim1 !_env !stk VALU _ = pure stk +bprim1 !_env !stk DBTX _ = pure stk +bprim1 !_env !stk SDBL _ = pure stk {-# INLINE bprim1 #-} bprim2 :: @@ -1917,7 +1923,7 @@ bprim2 !stk REFW i j = do v <- peekOff stk j IORef.writeIORef ref v stk <- bump stk - bpoke stk unitValue + bpoke stk unitClosure pure stk bprim2 !stk THRO _ _ = pure stk -- impossible bprim2 !stk TRCE _ _ = pure stk -- impossible @@ -1936,7 +1942,7 @@ yield :: Stack -> K -> IO () -yield !env !denv !activeThreads !stk !k = leap denv k +yield env !denv !activeThreads !stk !k = leap denv k where leap !denv0 (Mark a ps cs k) = do let denv = cs <> EC.withoutKeys denv0 ps @@ -2207,10 +2213,11 @@ cacheAdd0 ntys0 termSuperGroups sands cc = do rtm <- updateMap (M.fromList $ zip rs [ntm ..]) (refTm cc) -- check for missing references let arities = fmap (head . ANF.arities) int <> builtinArities + inlinfo = ANF.buildInlineMap int <> builtinInlineInfo rns = RN (refLookup "ty" rty) (refLookup "tm" rtm) (flip M.lookup arities) combinate :: Word64 -> (Reference, SuperGroup Symbol) -> (Word64, EnumMap Word64 Comb) combinate n (r, g) = - (n, emitCombs rns r n g) + (n, emitCombs rns r n $ ANF.inline inlinfo g) let combRefUpdates = (mapFromList $ zip [ntm ..] rs) let combIdFromRefMap = (M.fromList $ zip rs [ntm ..]) let newCacheableCombs = @@ -2225,7 +2232,8 @@ cacheAdd0 ntys0 termSuperGroups sands cc = do newCombRefs <- updateMap combRefUpdates (combRefs cc) (unresolvedNewCombs, unresolvedCacheableCombs, unresolvedNonCacheableCombs, updatedCombs) <- stateTVar (combs cc) \oldCombs -> let unresolvedNewCombs :: EnumMap Word64 (GCombs any CombIx) - unresolvedNewCombs = absurdCombs . mapFromList $ zipWith combinate [ntm ..] rgs + unresolvedNewCombs = + absurdCombs . sanitizeCombsOfForeignFuncs (sandboxed cc) sandboxedForeignFuncs . mapFromList $ zipWith combinate [ntm ..] rgs (unresolvedCacheableCombs, unresolvedNonCacheableCombs) = EC.mapToList unresolvedNewCombs & foldMap \(w, gcombs) -> if EC.member w newCacheableCombs diff --git a/unison-runtime/src/Unison/Runtime/Stack.hs b/unison-runtime/src/Unison/Runtime/Stack.hs index 330566207d..595bc2818d 100644 --- a/unison-runtime/src/Unison/Runtime/Stack.hs +++ b/unison-runtime/src/Unison/Runtime/Stack.hs @@ -34,7 +34,9 @@ module Unison.Runtime.Stack pattern XStack, packXStack, unpackXStack, - IOStack, + xStackIOToIO, + stackIOToIOX, + IOXStack, apX, fpX, spX, @@ -646,7 +648,7 @@ data Stack = Stack -- Unboxed representation of the Stack, used to force GHC optimizations in a few spots. type XStack = (# Int#, Int#, Int#, MutableByteArray# (PrimState IO), MutableArray# (PrimState IO) Closure #) -type IOStack = State# RealWorld -> (# State# RealWorld, XStack #) +type IOXStack = State# RealWorld -> (# State# RealWorld, XStack #) pattern XStack :: Int# -> Int# -> Int# -> MutableByteArray# RealWorld -> MutableArray# RealWorld Closure -> Stack pattern XStack {apX, fpX, spX, ustkX, bstkX} = Stack (I# apX) (I# fpX) (I# spX) (MutableByteArray ustkX) (MutableArray bstkX) @@ -663,6 +665,14 @@ unpackXStack :: Stack -> XStack unpackXStack (Stack (I# ap) (I# fp) (I# sp) (MutableByteArray ustk) (MutableArray bstk)) = (# ap, fp, sp, ustk, bstk #) {-# INLINE unpackXStack #-} +xStackIOToIO :: IOXStack -> IO Stack +xStackIOToIO f = IO $ \s -> case f s of (# s', x #) -> (# s', packXStack x #) +{-# INLINE xStackIOToIO #-} + +stackIOToIOX :: IO Stack -> IOXStack +stackIOToIOX (IO f) = \s -> case f s of (# s', x #) -> (# s', unpackXStack x #) +{-# INLINE stackIOToIOX #-} + instance Show Stack where show (Stack ap fp sp _ _) = "Stack " ++ show ap ++ " " ++ show fp ++ " " ++ show sp diff --git a/unison-runtime/tests/Unison/Test/Runtime/MCode/Serialization.hs b/unison-runtime/tests/Unison/Test/Runtime/MCode/Serialization.hs index 1b95a96b40..a9b82a272a 100644 --- a/unison-runtime/tests/Unison/Test/Runtime/MCode/Serialization.hs +++ b/unison-runtime/tests/Unison/Test/Runtime/MCode/Serialization.hs @@ -13,6 +13,7 @@ import Hedgehog hiding (Rec, Test, test) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import Unison.Prelude +import Unison.Runtime.Foreign.Function.Type (ForeignFunc) import Unison.Runtime.Interface import Unison.Runtime.MCode (Args (..), BPrim1, BPrim2, Branch, Comb, CombIx (..), GBranch (..), GComb (..), GCombInfo (..), GInstr (..), GRef (..), GSection (..), Instr, MLit (..), Ref, Section, UPrim1, UPrim2) import Unison.Runtime.Machine (Combs) @@ -33,6 +34,9 @@ test = ] EasyTest.expect success +genForeignCall :: Gen ForeignFunc +genForeignCall = Gen.enumBounded + genEnumMap :: (EC.EnumKey k) => Gen k -> Gen v -> Gen (EnumMap k v) genEnumMap genK genV = EC.mapFromList <$> Gen.list (Range.linear 0 10) ((,) <$> genK <*> genV) @@ -116,7 +120,7 @@ genInstr = UPrim2 <$> genUPrim2 <*> genSmallInt <*> genSmallInt, BPrim1 <$> genBPrim1 <*> genSmallInt, BPrim2 <$> genBPrim2 <*> genSmallInt <*> genSmallInt, - ForeignCall <$> Gen.bool <*> genSmallWord64 <*> genArgs, + ForeignCall <$> Gen.bool <*> genForeignCall <*> genArgs, SetDyn <$> genSmallWord64 <*> genSmallInt, Capture <$> genSmallWord64, Name <$> genGRef <*> genArgs, diff --git a/unison-runtime/unison-runtime.cabal b/unison-runtime/unison-runtime.cabal index 0477ee1bf5..ffb43b0179 100644 --- a/unison-runtime/unison-runtime.cabal +++ b/unison-runtime/unison-runtime.cabal @@ -48,6 +48,7 @@ library Unison.Runtime.Exception Unison.Runtime.Foreign Unison.Runtime.Foreign.Function + Unison.Runtime.Foreign.Function.Type Unison.Runtime.Interface Unison.Runtime.IOSource Unison.Runtime.Machine diff --git a/unison-share-api/package.yaml b/unison-share-api/package.yaml index 2df959ab4e..8ed217cf4d 100644 --- a/unison-share-api/package.yaml +++ b/unison-share-api/package.yaml @@ -16,7 +16,6 @@ dependencies: - bytes - bytestring - containers - - cryptonite - Diff - directory - errors diff --git a/unison-share-api/src/Unison/Server/CodebaseServer.hs b/unison-share-api/src/Unison/Server/CodebaseServer.hs index 1bbdfa5e24..a9c28438f9 100644 --- a/unison-share-api/src/Unison/Server/CodebaseServer.hs +++ b/unison-share-api/src/Unison/Server/CodebaseServer.hs @@ -10,9 +10,7 @@ import Control.Concurrent.Async (race) import Control.Exception (ErrorCall (..), throwIO) import Control.Monad.Reader import Control.Monad.Trans.Except -import Crypto.Random qualified as Crypto import Data.Aeson () -import Data.ByteArray.Encoding qualified as BE import Data.ByteString qualified as Strict import Data.ByteString.Char8 (unpack) import Data.ByteString.Char8 qualified as C8 @@ -37,7 +35,6 @@ import Network.Wai.Handler.Warp setBeforeMainLoop, setHost, setPort, - withApplicationSettings, ) import Network.Wai.Middleware.Cors (cors, corsMethods, corsOrigins, simpleCorsResourcePolicy) import Servant @@ -48,7 +45,7 @@ import Servant serve, throwError, ) -import Servant qualified as Servant +import Servant qualified import Servant.API ( Accept (..), Capture, @@ -398,21 +395,6 @@ app :: app env rt codebase uiPath expectedToken allowCorsHost = corsPolicy allowCorsHost $ serve appAPI $ server env rt codebase uiPath expectedToken --- | The Token is used to help prevent multiple users on a machine gain access to --- each others codebases. --- --- Generate a cryptographically secure random token. --- https://neilmadden.blog/2018/08/30/moving-away-from-uuids/ --- --- E.g. --- >>> genToken --- "uxf85C7Y0B6om47" -genToken :: IO Strict.ByteString -genToken = do - BE.convertToBase @ByteString BE.Base64URLUnpadded <$> Crypto.getRandomBytes numRandomBytes - where - numRandomBytes = 10 - data Waiter a = Waiter { notify :: a -> IO (), waitFor :: IO a @@ -475,21 +457,23 @@ startServer env opts rt codebase onStart = do envUI <- canonicalizePath $ fromMaybe (FilePath.takeDirectory exePath "ui") (codebaseUIPath opts) token <- case token opts of Just t -> return $ C8.pack t - _ -> genToken + Nothing -> return $ C8.pack "codebase" let baseUrl = BaseUrl (fromMaybe "http://127.0.0.1" (host opts)) token let settings = defaultSettings - & maybe id setPort (port opts) - & maybe id (setHost . fromString) (host opts) - let a = app env rt codebase envUI token (allowCorsHost opts) + & setPort (fromMaybe 5858 $ port opts) + & (setHost . fromString) (fromMaybe "127.0.0.1" $ host opts) + let app' = app env rt codebase envUI token (allowCorsHost opts) case port opts of - Nothing -> withApplicationSettings settings (pure a) (onStart . baseUrl) - Just p -> do + Nothing -> withPort settings baseUrl app' 5858 + Just p -> withPort settings baseUrl app' p + where + withPort settings baseUrl app' p = do started <- mkWaiter let settings' = setBeforeMainLoop (notify started ()) settings result <- race - (runSettings settings' a) + (runSettings settings' app') (waitFor started *> onStart (baseUrl p)) case result of Left () -> throwIO $ ErrorCall "Server exited unexpectedly!" @@ -518,16 +502,30 @@ serveIndex path = do serveUI :: FilePath -> Server WebUI serveUI path _ = serveIndex path --- Apply cors if there is allow-cors-host defined +{- + Allows CORS requests from UCM Desktop: + * Mac/Linux: tauri://localhost + * Windows: https://tauri.localhost, http://tauri.localhost +-} corsPolicy :: Maybe String -> Middleware -corsPolicy = maybe id \allowCorsHost -> - cors $ - const $ - Just - simpleCorsResourcePolicy - { corsMethods = ["GET", "OPTIONS"], - corsOrigins = Just ([C8.pack allowCorsHost], True) - } +corsPolicy allowCorsHost = + case allowCorsHost of + Just host -> + corsPolicy_ (host : tauriHosts) + Nothing -> + corsPolicy_ tauriHosts + where + tauriHosts = + ["tauri://localhost", "https://tauri.localhost", "http://tauri.localhost"] + + corsPolicy_ hosts = + cors $ + const $ + Just + simpleCorsResourcePolicy + { corsMethods = ["GET", "OPTIONS"], + corsOrigins = Just (fmap C8.pack hosts, True) + } server :: BackendEnv -> @@ -577,35 +575,35 @@ serveProjectsCodebaseServerAPI codebase rt projectName branchName = do projectAndBranchName = ProjectAndBranch projectName branchName namespaceListingEndpoint rel name = do root <- resolveProjectRootHash codebase projectAndBranchName - setCacheControl <$> NamespaceListing.serve codebase (Right $ root) rel name + setCacheControl <$> NamespaceListing.serve codebase (Right root) rel name namespaceDetailsEndpoint namespaceName renderWidth = do root <- resolveProjectRootHash codebase projectAndBranchName - setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Right $ root) renderWidth + setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Right root) renderWidth serveDefinitionsEndpoint relativePath rawHqns renderWidth suff = do root <- resolveProjectRootHash codebase projectAndBranchName - setCacheControl <$> serveDefinitions rt codebase (Right $ root) relativePath rawHqns renderWidth suff + setCacheControl <$> serveDefinitions rt codebase (Right root) relativePath rawHqns renderWidth suff serveFuzzyFindEndpoint relativePath limit renderWidth query = do root <- resolveProjectRootHash codebase projectAndBranchName - setCacheControl <$> serveFuzzyFind codebase (Right $ root) relativePath limit renderWidth query + setCacheControl <$> serveFuzzyFind codebase (Right root) relativePath limit renderWidth query serveTermSummaryEndpoint shortHash mayName relativeTo renderWidth = do root <- resolveProjectRootHash codebase projectAndBranchName - setCacheControl <$> serveTermSummary codebase shortHash mayName (Right $ root) relativeTo renderWidth + setCacheControl <$> serveTermSummary codebase shortHash mayName (Right root) relativeTo renderWidth serveTypeSummaryEndpoint shortHash mayName relativeTo renderWidth = do root <- resolveProjectRootHash codebase projectAndBranchName - setCacheControl <$> serveTypeSummary codebase shortHash mayName (Right $ root) relativeTo renderWidth + setCacheControl <$> serveTypeSummary codebase shortHash mayName (Right root) relativeTo renderWidth -resolveProjectRoot :: (Codebase IO v a) -> (ProjectAndBranch ProjectName ProjectBranchName) -> Backend IO (V2.CausalBranch Sqlite.Transaction) +resolveProjectRoot :: Codebase IO v a -> ProjectAndBranch ProjectName ProjectBranchName -> Backend IO (V2.CausalBranch Sqlite.Transaction) resolveProjectRoot codebase projectAndBranchName@(ProjectAndBranch projectName branchName) = do mayCB <- liftIO . Codebase.runTransaction codebase $ Codebase.getShallowProjectRootByNames projectAndBranchName case mayCB of Nothing -> throwError (Backend.ProjectBranchNameNotFound projectName branchName) Just cb -> pure cb -resolveProjectRootHash :: (Codebase IO v a) -> (ProjectAndBranch ProjectName ProjectBranchName) -> Backend IO CausalHash +resolveProjectRootHash :: Codebase IO v a -> ProjectAndBranch ProjectName ProjectBranchName -> Backend IO CausalHash resolveProjectRootHash codebase projectAndBranchName = do resolveProjectRoot codebase projectAndBranchName <&> Causal.causalHash @@ -628,11 +626,11 @@ serveProjectDiffTermsEndpoint codebase rt projectName oldBranchRef newBranchRef where width = Pretty.Width 80 -contextForProjectBranch :: (Codebase IO v a) -> ProjectName -> ProjectBranchName -> Backend IO (PrettyPrintEnvDecl, NameSearch Sqlite.Transaction) +contextForProjectBranch :: Codebase IO v a -> ProjectName -> ProjectBranchName -> Backend IO (PrettyPrintEnvDecl, NameSearch Sqlite.Transaction) contextForProjectBranch codebase projectName branchName = do projectRootHash <- resolveProjectRootHash codebase (ProjectAndBranch projectName branchName) projectRootBranch <- liftIO $ Codebase.expectBranchForHash codebase projectRootHash - hashLength <- liftIO $ Codebase.runTransaction codebase $ Codebase.hashLength + hashLength <- liftIO $ Codebase.runTransaction codebase Codebase.hashLength let names = Branch.toNames (Branch.head projectRootBranch) let pped = PPED.makePPED (PPE.hqNamer hashLength names) (PPE.suffixifyByHash names) let nameSearch = Names.makeNameSearch hashLength names diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index 2e42b8ac70..52cb824d14 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -91,7 +91,6 @@ library , bytes , bytestring , containers - , cryptonite , directory , errors , extra diff --git a/unison-src/builtin-tests/interpreter-tests.output.md b/unison-src/builtin-tests/interpreter-tests.output.md index 8f313d114f..87de1b4977 100644 --- a/unison-src/builtin-tests/interpreter-tests.output.md +++ b/unison-src/builtin-tests/interpreter-tests.output.md @@ -4,7 +4,7 @@ If you want to add or update tests, you can create a branch of that project, and Before merging the PR on Github, we'll merge your branch on Share and restore `runtime_tests_version` to /main or maybe a release. -``` ucm :hide:error +``` ucm :hide :error scratch/main> this is a hack to trigger an error, in order to swallow any error on the next line. scratch/main> we delete the project to avoid any merge conflicts or complaints from ucm. diff --git a/unison-src/builtin-tests/jit-tests.output.md b/unison-src/builtin-tests/jit-tests.output.md index 616d2d5d9c..94225ebd14 100644 --- a/unison-src/builtin-tests/jit-tests.output.md +++ b/unison-src/builtin-tests/jit-tests.output.md @@ -4,6 +4,18 @@ If you want to add or update tests, you can create a branch of that project, and Before merging the PR on Github, we'll merge your branch on Share and restore `runtime_tests_version` to /main or maybe a release. +``` ucm :hide :error +scratch/main> this is a hack to trigger an error, in order to swallow any error on the next line. + +scratch/main> we delete the project to avoid any merge conflicts or complaints from ucm. + +scratch/main> delete.project runtime-tests +``` + +``` ucm :hide +scratch/main> clone @unison/runtime-tests/releases/0.0.1 runtime-tests/selected +``` + ``` ucm runtime-tests/selected> run.native tests @@ -12,8 +24,8 @@ runtime-tests/selected> run.native tests runtime-tests/selected> run.native tests.jit.only () - ``` + Per Dan: It's testing a flaw in how we were sending code from a scratch file to the native runtime, when that happened multiple times. Related to the verifiable refs and recursive functions. @@ -27,19 +39,18 @@ foo = do go 1000 ``` -``` ucm - +``` ucm :added-by-ucm Loading changes detected in scratch.u. I found and typechecked these definitions in scratch.u. If you do an `add` or `update`, here's how your codebase would change: - + ⍟ These new definitions are ok to `add`: foo : '{Exception} () - ``` + ``` ucm scratch/main> run.native foo @@ -48,20 +59,19 @@ scratch/main> run.native foo scratch/main> run.native foo () - ``` + This can also only be tested by separately running this test, because it is exercising the protocol that ucm uses to talk to the jit during an exception. -``` ucm +``` ucm :error runtime-tests/selected> run.native testBug 💔💥 - + I've encountered a call to builtin.bug with the following value: - - "testing" + "testing" ``` diff --git a/unison-src/transcripts-manual/rewrites.output.md b/unison-src/transcripts-manual/rewrites.output.md index 3f0a21e692..d591c74597 100644 --- a/unison-src/transcripts-manual/rewrites.output.md +++ b/unison-src/transcripts-manual/rewrites.output.md @@ -81,7 +81,7 @@ rule1 f x = term x + 1 ==> Nat.increment x term a -> f a ==> f -type Optional2 a = Some2 a | None2 +type Optional2 a = None2 | Some2 a rule2 x = @rewrite signature Optional ==> Optional2 ``` @@ -111,7 +111,7 @@ rule1 f x = term x + 1 ==> Nat.increment x term a -> f a ==> f -type Optional2 a = Some2 a | None2 +type Optional2 a = None2 | Some2 a rule2 x = @rewrite signature Optional ==> Optional2 ``` diff --git a/unison-src/transcripts-using-base/fix5178.md b/unison-src/transcripts-using-base/fix5178.md new file mode 100644 index 0000000000..e03d38eed5 --- /dev/null +++ b/unison-src/transcripts-using-base/fix5178.md @@ -0,0 +1,20 @@ +``` unison +foo = {{ +@source{Stream.emit} +}} +``` + +``` ucm +scratch/main> add +``` + +Viewing `foo` via `scratch/main> ui` shows the correct source, but `display foo` gives us an error message (but not an error – this is incorrectly considered a successful result) + +I think there are two separate issues here: + +1. this message should be considered an error, not success; and +2. this should actually work like `ui` and give us the source of the ability member, not complain about there being no such term in the codebase. + +``` ucm :error :bug +scratch/main> display foo +``` diff --git a/unison-src/transcripts-using-base/fix5178.output.md b/unison-src/transcripts-using-base/fix5178.output.md new file mode 100644 index 0000000000..c01343f2db --- /dev/null +++ b/unison-src/transcripts-using-base/fix5178.output.md @@ -0,0 +1,43 @@ +``` unison +foo = {{ +@source{Stream.emit} +}} +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo : Doc2 +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + foo : Doc2 +``` + +Viewing `foo` via `scratch/main> ui` shows the correct source, but `display foo` gives us an error message (but not an error – this is incorrectly considered a successful result) + +I think there are two separate issues here: + +1. this message should be considered an error, not success; and +2. this should actually work like `ui` and give us the source of the ability member, not complain about there being no such term in the codebase. + +``` ucm :error :bug +scratch/main> display foo + + -- The name #rfi1v9429f is assigned to the reference + ShortHash {prefix = + "rfi1v9429f9qluv533l2iba77aadttilrpmnhljfapfnfa6sru2nr8ibpqvib9nc4s4nb9s1as45upsfqfqe6ivqi2p82b2vd866it8", + cycle = Nothing, cid = Nothing}, which is missing from the + codebase. + Tip: You might need to repair the codebase manually. +``` diff --git a/unison-src/transcripts/alias-many.md b/unison-src/transcripts/alias-many.md index 4cc88d489a..e693e50a5b 100644 --- a/unison-src/transcripts/alias-many.md +++ b/unison-src/transcripts/alias-many.md @@ -1,7 +1,7 @@ ``` ucm :hide scratch/main> builtins.merge lib.builtins ``` -``` unison :hide:all +``` unison :hide-all List.adjacentPairs : [a] -> [(a, a)] List.adjacentPairs as = go xs acc = diff --git a/unison-src/transcripts/errors/dont-hide-unexpected-ucm-errors.output.md b/unison-src/transcripts/errors/dont-hide-unexpected-ucm-errors.output.md index 218f5288a2..322dfe8484 100644 --- a/unison-src/transcripts/errors/dont-hide-unexpected-ucm-errors.output.md +++ b/unison-src/transcripts/errors/dont-hide-unexpected-ucm-errors.output.md @@ -1,6 +1,6 @@ Since this code block is expecting an error, we still hide it. It seems unusual to want to hide an error, but maybe it’s just too verbose or something. This follows the author’s intent. -``` ucm :hide:error +``` ucm :hide :error scratch/main> help pull scratch/main> not.a.command diff --git a/unison-src/transcripts/errors/dont-hide-unexpected-unison-errors.output.md b/unison-src/transcripts/errors/dont-hide-unexpected-unison-errors.output.md index b0874d13e7..e73b5e616a 100644 --- a/unison-src/transcripts/errors/dont-hide-unexpected-unison-errors.output.md +++ b/unison-src/transcripts/errors/dont-hide-unexpected-unison-errors.output.md @@ -1,6 +1,6 @@ Since this code block is expecting an error, we still hide it. It seems unusual to want to hide an error, but maybe it’s just too verbose or something. This follows the author’s intent. -``` unison :hide:error +``` unison :hide :error x + x + ``` diff --git a/unison-src/transcripts/errors/info-string-parse-error.output.md b/unison-src/transcripts/errors/info-string-parse-error.output.md index 7c6ea84d4b..3ef6a22af4 100644 --- a/unison-src/transcripts/errors/info-string-parse-error.output.md +++ b/unison-src/transcripts/errors/info-string-parse-error.output.md @@ -3,4 +3,4 @@ 1 | ``` ucm :hode | ^ unexpected ':' -expecting ":added-by-ucm", ":error", ":hide", ":hide:all", or newline +expecting ":added-by-ucm", ":bug", ":error", ":hide", ":hide-all", or newline diff --git a/unison-src/transcripts/errors/missing-result-typed.md b/unison-src/transcripts/errors/missing-result-typed.md index 0e6e52b806..70949bec81 100644 --- a/unison-src/transcripts/errors/missing-result-typed.md +++ b/unison-src/transcripts/errors/missing-result-typed.md @@ -1,6 +1,6 @@ ### Transcript parser hidden errors -When an error is encountered in a `unison :hide:all` block +When an error is encountered in a `unison :hide-all` block then the transcript parser should print the stanza and surface a helpful message. @@ -8,7 +8,7 @@ and surface a helpful message. scratch/main> builtins.merge ``` -``` unison :hide:all +``` unison :hide-all a : Nat a = b = 24 diff --git a/unison-src/transcripts/errors/missing-result-typed.output.md b/unison-src/transcripts/errors/missing-result-typed.output.md index 87c2308bec..f28268036c 100644 --- a/unison-src/transcripts/errors/missing-result-typed.output.md +++ b/unison-src/transcripts/errors/missing-result-typed.output.md @@ -1,6 +1,6 @@ ### Transcript parser hidden errors -When an error is encountered in a `unison :hide:all` block +When an error is encountered in a `unison :hide-all` block then the transcript parser should print the stanza and surface a helpful message. @@ -8,7 +8,7 @@ and surface a helpful message. scratch/main> builtins.merge ``` -``` unison :hide:all +``` unison :hide-all a : Nat a = b = 24 diff --git a/unison-src/transcripts/errors/missing-result.md b/unison-src/transcripts/errors/missing-result.md index f177ee81c8..a94c3bb3c5 100644 --- a/unison-src/transcripts/errors/missing-result.md +++ b/unison-src/transcripts/errors/missing-result.md @@ -1,10 +1,10 @@ ### Transcript parser hidden errors -When an error is encountered in a `unison :hide:all` block +When an error is encountered in a `unison :hide-all` block then the transcript parser should print the stanza and surface a helpful message. -``` unison :hide:all +``` unison :hide-all x = y = 24 ``` diff --git a/unison-src/transcripts/errors/missing-result.output.md b/unison-src/transcripts/errors/missing-result.output.md index fb0ab98c9f..faf91774a6 100644 --- a/unison-src/transcripts/errors/missing-result.output.md +++ b/unison-src/transcripts/errors/missing-result.output.md @@ -1,10 +1,10 @@ ### Transcript parser hidden errors -When an error is encountered in a `unison :hide:all` block +When an error is encountered in a `unison :hide-all` block then the transcript parser should print the stanza and surface a helpful message. -``` unison :hide:all +``` unison :hide-all x = y = 24 ``` diff --git a/unison-src/transcripts/errors/obsolete-bug.md b/unison-src/transcripts/errors/obsolete-bug.md new file mode 100644 index 0000000000..6f2a9641eb --- /dev/null +++ b/unison-src/transcripts/errors/obsolete-bug.md @@ -0,0 +1,5 @@ +This transcript will error, because we’re claiming that the stanza has a bug, but `help` works as expected. + +``` ucm :bug +scratch/main> help edit +``` diff --git a/unison-src/transcripts/errors/obsolete-bug.output.md b/unison-src/transcripts/errors/obsolete-bug.output.md new file mode 100644 index 0000000000..b88fe47b32 --- /dev/null +++ b/unison-src/transcripts/errors/obsolete-bug.output.md @@ -0,0 +1,15 @@ +This transcript will error, because we’re claiming that the stanza has a bug, but `help` works as expected. + +``` ucm :bug +scratch/main> help edit + + edit + `edit foo` prepends the definition of `foo` to the top of the most recently saved file. + `edit` without arguments invokes a search to select a definition for editing, which requires that `fzf` can be found within your PATH. +``` + +🎉 + +## You fixed a bug\! + +The stanza above with `:bug` is now passing\! You can remove `:bug` and close any appropriate Github issues. diff --git a/unison-src/transcripts/errors/obsolete-error-bug.md b/unison-src/transcripts/errors/obsolete-error-bug.md new file mode 100644 index 0000000000..39b6f667ad --- /dev/null +++ b/unison-src/transcripts/errors/obsolete-error-bug.md @@ -0,0 +1,5 @@ +This transcript will fail, because we’re claiming that the stanza has a bug, but `do.something` errors as expected. + +``` ucm :error :bug +scratch/main> do.something +``` diff --git a/unison-src/transcripts/errors/obsolete-error-bug.output.md b/unison-src/transcripts/errors/obsolete-error-bug.output.md new file mode 100644 index 0000000000..7a3a16789b --- /dev/null +++ b/unison-src/transcripts/errors/obsolete-error-bug.output.md @@ -0,0 +1,19 @@ +This transcript will fail, because we’re claiming that the stanza has a bug, but `do.something` errors as expected. + +``` ucm :error :bug +scratch/main> do.something +``` + +🎉 + +## You fixed a bug\! + +The stanza above marked with `:error :bug` is now failing with + +``` +⚠️ +I don't know how to do.something. Type `help` or `?` to get +help. +``` + +so you can remove `:bug` and close any appropriate Github issues. If the error message is different from the expected error message, open a new issue and reference it in this transcript. diff --git a/unison-src/transcripts/errors/ucm-hide-all-error.md b/unison-src/transcripts/errors/ucm-hide-all-error.md index 7444155923..7a56730f69 100644 --- a/unison-src/transcripts/errors/ucm-hide-all-error.md +++ b/unison-src/transcripts/errors/ucm-hide-all-error.md @@ -2,10 +2,10 @@ Dangerous scary words! -When an expected error is not encountered in a `ucm :hide:all` block +When an expected error is not encountered in a `ucm :hide-all` block then the transcript parser should print the stanza and surface a helpful message. -``` ucm :hide:all:error +``` ucm :hide-all :error scratch/main> history ``` diff --git a/unison-src/transcripts/errors/ucm-hide-all-error.output.md b/unison-src/transcripts/errors/ucm-hide-all-error.output.md index c416257ade..6f7c903cbd 100644 --- a/unison-src/transcripts/errors/ucm-hide-all-error.output.md +++ b/unison-src/transcripts/errors/ucm-hide-all-error.output.md @@ -2,11 +2,11 @@ Dangerous scary words\! -When an expected error is not encountered in a `ucm :hide:all` block +When an expected error is not encountered in a `ucm :hide-all` block then the transcript parser should print the stanza and surface a helpful message. -``` ucm :hide:all:error +``` ucm :hide-all :error scratch/main> history ``` diff --git a/unison-src/transcripts/errors/ucm-hide-all.md b/unison-src/transcripts/errors/ucm-hide-all.md index cb79d26753..a3e6d3443f 100644 --- a/unison-src/transcripts/errors/ucm-hide-all.md +++ b/unison-src/transcripts/errors/ucm-hide-all.md @@ -2,10 +2,10 @@ Dangerous scary words! -When an error is encountered in a `ucm :hide:all` block +When an error is encountered in a `ucm :hide-all` block then the transcript parser should print the stanza and surface a helpful message. -``` ucm :hide:all +``` ucm :hide-all scratch/main> move.namespace foo bar ``` diff --git a/unison-src/transcripts/errors/ucm-hide-all.output.md b/unison-src/transcripts/errors/ucm-hide-all.output.md index 2753dd7f11..fc6d21cbc6 100644 --- a/unison-src/transcripts/errors/ucm-hide-all.output.md +++ b/unison-src/transcripts/errors/ucm-hide-all.output.md @@ -2,11 +2,11 @@ Dangerous scary words\! -When an error is encountered in a `ucm :hide:all` block +When an error is encountered in a `ucm :hide-all` block then the transcript parser should print the stanza and surface a helpful message. -``` ucm :hide:all +``` ucm :hide-all scratch/main> move.namespace foo bar ``` diff --git a/unison-src/transcripts/errors/ucm-hide-error.output.md b/unison-src/transcripts/errors/ucm-hide-error.output.md index e2045b6ee5..8deec0bfaf 100644 --- a/unison-src/transcripts/errors/ucm-hide-error.output.md +++ b/unison-src/transcripts/errors/ucm-hide-error.output.md @@ -6,7 +6,7 @@ When an expected error is not encountered in a `ucm :hide` block then the transcript parser should print the stanza and surface a helpful message. -``` ucm :hide:error +``` ucm :hide :error scratch/main> history ``` diff --git a/unison-src/transcripts/errors/unison-hide-all-error.md b/unison-src/transcripts/errors/unison-hide-all-error.md index e35de94e1d..ca2bd023ba 100644 --- a/unison-src/transcripts/errors/unison-hide-all-error.md +++ b/unison-src/transcripts/errors/unison-hide-all-error.md @@ -1,9 +1,9 @@ ### Transcript parser hidden errors -When an expected error is not encountered in a `unison :hide:all:error` block +When an expected error is not encountered in a `unison :hide-all :error` block then the transcript parser should print the stanza and surface a helpful message. -``` unison :hide:all:error +``` unison :hide-all :error myVal = 3 ``` diff --git a/unison-src/transcripts/errors/unison-hide-all-error.output.md b/unison-src/transcripts/errors/unison-hide-all-error.output.md index 3652dfebe5..6205069903 100644 --- a/unison-src/transcripts/errors/unison-hide-all-error.output.md +++ b/unison-src/transcripts/errors/unison-hide-all-error.output.md @@ -1,10 +1,10 @@ ### Transcript parser hidden errors -When an expected error is not encountered in a `unison :hide:all:error` block +When an expected error is not encountered in a `unison :hide-all :error` block then the transcript parser should print the stanza and surface a helpful message. -``` unison :hide:all:error +``` unison :hide-all :error myVal = 3 ``` diff --git a/unison-src/transcripts/errors/unison-hide-all.md b/unison-src/transcripts/errors/unison-hide-all.md index 48907e75e7..9288252881 100644 --- a/unison-src/transcripts/errors/unison-hide-all.md +++ b/unison-src/transcripts/errors/unison-hide-all.md @@ -1,9 +1,9 @@ ### Transcript parser hidden errors -When an error is encountered in a `unison :hide:all` block +When an error is encountered in a `unison :hide-all` block then the transcript parser should print the stanza and surface a helpful message. -``` unison :hide:all +``` unison :hide-all g 3 ``` diff --git a/unison-src/transcripts/errors/unison-hide-all.output.md b/unison-src/transcripts/errors/unison-hide-all.output.md index c27b7dd28f..89cd4724b7 100644 --- a/unison-src/transcripts/errors/unison-hide-all.output.md +++ b/unison-src/transcripts/errors/unison-hide-all.output.md @@ -1,10 +1,10 @@ ### Transcript parser hidden errors -When an error is encountered in a `unison :hide:all` block +When an error is encountered in a `unison :hide-all` block then the transcript parser should print the stanza and surface a helpful message. -``` unison :hide:all +``` unison :hide-all g 3 ``` diff --git a/unison-src/transcripts/errors/unison-hide-error.output.md b/unison-src/transcripts/errors/unison-hide-error.output.md index 3a9477e8f8..7bc464673c 100644 --- a/unison-src/transcripts/errors/unison-hide-error.output.md +++ b/unison-src/transcripts/errors/unison-hide-error.output.md @@ -4,7 +4,7 @@ When an expected error is not encountered in a `unison :hide:error` block then the transcript parser should print the stanza and surface a helpful message. -``` unison :hide:error +``` unison :hide :error myVal = 3 ``` diff --git a/unison-src/transcripts/fix2840.md b/unison-src/transcripts/fix2840.md index 6c6ac6abe9..31d4c103df 100644 --- a/unison-src/transcripts/fix2840.md +++ b/unison-src/transcripts/fix2840.md @@ -6,7 +6,7 @@ scratch/main> builtins.merge First, a few \[hidden] definitions necessary for typechecking a simple Doc2. -``` unison :hide:all +``` unison :hide-all structural type Optional a = None | Some a unique[b7a4fb87e34569319591130bf3ec6e24c9955b6a] type Doc2 diff --git a/unison-src/transcripts/hello.md b/unison-src/transcripts/hello.md index 7f5937a353..566e6b5694 100644 --- a/unison-src/transcripts/hello.md +++ b/unison-src/transcripts/hello.md @@ -52,9 +52,9 @@ This works for `ucm` blocks as well. scratch/main> rename.term x answerToUltimateQuestionOfLife ``` -Doing `unison :hide:all` hides the block altogether, both input and output - this is useful for doing behind-the-scenes control of `ucm`'s state. +Doing `unison :hide-all` hides the block altogether, both input and output - this is useful for doing behind-the-scenes control of `ucm`'s state. -``` unison :hide:all +``` unison :hide-all > [: you won't see me :] ``` diff --git a/unison-src/transcripts/hello.output.md b/unison-src/transcripts/hello.output.md index c7564924b7..9ab978d5ce 100644 --- a/unison-src/transcripts/hello.output.md +++ b/unison-src/transcripts/hello.output.md @@ -25,7 +25,7 @@ Take a look at [the elaborated output](hello.output.md) to see what this file lo In the `unison` fenced block, you can give an (optional) file name (defaults to `scratch.u`), like so: -``` unison myfile.u +``` unison myfile.u x = 42 ``` @@ -72,7 +72,7 @@ This works for `ucm` blocks as well. scratch/main> rename.term x answerToUltimateQuestionOfLife ``` -Doing `unison :hide:all` hides the block altogether, both input and output - this is useful for doing behind-the-scenes control of `ucm`'s state. +Doing `unison :hide-all` hides the block altogether, both input and output - this is useful for doing behind-the-scenes control of `ucm`'s state. ## Expecting failures diff --git a/unison-src/transcripts/idempotent/ability-order-doesnt-affect-hash.md b/unison-src/transcripts/idempotent/ability-order-doesnt-affect-hash.md index 3656daaba2..da9c866125 100644 --- a/unison-src/transcripts/idempotent/ability-order-doesnt-affect-hash.md +++ b/unison-src/transcripts/idempotent/ability-order-doesnt-affect-hash.md @@ -27,6 +27,6 @@ scratch/main> add scratch/main> names term1 Term - Hash: #8hum58rlih + Hash: #42m1ui9g56 Names: term1 term2 ``` diff --git a/unison-src/transcripts/idempotent/bug.md b/unison-src/transcripts/idempotent/bug.md new file mode 100644 index 0000000000..9469b77067 --- /dev/null +++ b/unison-src/transcripts/idempotent/bug.md @@ -0,0 +1,19 @@ +This tests that `:bug` behaves similarly to `:error` when the stanza fails. + +``` ucm :bug +scratch/main> do.something + + ⚠️ + I don't know how to do.something. Type `help` or `?` to get + help. +``` + +And when combined with `:error`, it should expect a successful result. + +``` ucm :error :bug +scratch/main> help edit + + edit + `edit foo` prepends the definition of `foo` to the top of the most recently saved file. + `edit` without arguments invokes a search to select a definition for editing, which requires that `fzf` can be found within your PATH. +``` diff --git a/unison-src/transcripts/idempotent/find-by-type.md b/unison-src/transcripts/idempotent/find-by-type.md index 156b3a7f72..286b85c633 100644 --- a/unison-src/transcripts/idempotent/find-by-type.md +++ b/unison-src/transcripts/idempotent/find-by-type.md @@ -48,7 +48,7 @@ scratch/main> find : Text I couldn't find exact type matches, resorting to fuzzy matching... - 1. bar : Text -> A - 2. baz : A -> Text + 1. baz : A -> Text + 2. bar : Text -> A 3. A.A : Text -> A ``` diff --git a/unison-src/transcripts/idempotent/fix-5354.md b/unison-src/transcripts/idempotent/fix-5354.md new file mode 100644 index 0000000000..84de08b65f --- /dev/null +++ b/unison-src/transcripts/idempotent/fix-5354.md @@ -0,0 +1,45 @@ +``` ucm +scratch/main> builtins.mergeio + + Done. +``` + +``` unison :error +> todo "" + +foo = 42 +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + foo : Nat + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 💔💥 + + I've encountered a call to builtin.todo with the following + value: + + "" + + Stack trace: + todo + #0k89ebstt4 +``` + +``` ucm +scratch/main> add + + ⍟ I've added these definitions: + + foo : Nat +``` diff --git a/unison-src/transcripts/idempotent/fix2254.md b/unison-src/transcripts/idempotent/fix2254.md index 694c90acb4..6079ba210a 100644 --- a/unison-src/transcripts/idempotent/fix2254.md +++ b/unison-src/transcripts/idempotent/fix2254.md @@ -84,15 +84,15 @@ scratch/a2> update scratch/a2> view A NeedsA f f2 f3 g type A a b c d - = A a - | D d - | E a d + = E a d | B b + | A a + | D d | C c structural type NeedsA a b - = NeedsA (A a b Nat Nat) - | Zoink Text + = Zoink Text + | NeedsA (A a b Nat Nat) f : A Nat Nat Nat Nat -> Nat f = cases diff --git a/unison-src/transcripts/idempotent/fix5337.md b/unison-src/transcripts/idempotent/fix5337.md new file mode 100644 index 0000000000..558f763771 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix5337.md @@ -0,0 +1,30 @@ +``` ucm +scratch/main> builtins.mergeio + + Done. +``` + +The following `Doc` fails to typecheck with `ucm` `0.5.26`: + +``` unison :bug +testDoc : Doc2 +testDoc = {{ + key: '{{ docWord "value" }}'. +}} +``` + +``` ucm :added-by-ucm + Loading changes detected in scratch.u. + + I got confused here: + + 3 | key: '{{ docWord "value" }}'. + + + I was surprised to find a . here. + I was expecting one of these instead: + + * end of input +``` + +The same code typechecks ok with `0.5.25`. diff --git a/unison-src/transcripts/idempotent/fix5448.md b/unison-src/transcripts/idempotent/fix5448.md new file mode 100644 index 0000000000..fc71f75da7 --- /dev/null +++ b/unison-src/transcripts/idempotent/fix5448.md @@ -0,0 +1,12 @@ +``` unison :hide +type NewType = NewType +main = do NewType +``` + +You shouldn't have to `add` a type before using it with `run`. + +``` ucm +scratch/main> run main + + NewType +``` diff --git a/unison-src/transcripts/idempotent/kind-inference.md b/unison-src/transcripts/idempotent/kind-inference.md index cc12acd30d..3553d9941e 100644 --- a/unison-src/transcripts/idempotent/kind-inference.md +++ b/unison-src/transcripts/idempotent/kind-inference.md @@ -31,9 +31,10 @@ unique type T a Loading changes detected in scratch.u. Kind mismatch arising from - 3 | | StarStar (a Nat) + 2 | = Star a - a doesn't expect an argument; however, it is applied to Nat. + The arrow type (->) expects arguments of kind Type; however, + it is applied to a which has kind: Type -> Type. ``` ## Kinds are inferred by decl component diff --git a/unison-src/transcripts/idempotent/move-all.md b/unison-src/transcripts/idempotent/move-all.md index 5601aafa68..3a7a4abd7b 100644 --- a/unison-src/transcripts/idempotent/move-all.md +++ b/unison-src/transcripts/idempotent/move-all.md @@ -96,7 +96,7 @@ scratch/main> history Bar Note: The most recent namespace hash is immediately below this message. - ⊙ 1. #o7vuviel4c + ⊙ 1. #hk3a3lsc2e + Adds / updates: @@ -106,7 +106,7 @@ scratch/main> history Bar T.T - □ 2. #c5cggiaumo (start of history) + □ 2. #vqc50q3b3v (start of history) ``` ## Happy Path - Just term diff --git a/unison-src/transcripts/idempotent/move-namespace.md b/unison-src/transcripts/idempotent/move-namespace.md index 59a1e7ae71..0b8b967bab 100644 --- a/unison-src/transcripts/idempotent/move-namespace.md +++ b/unison-src/transcripts/idempotent/move-namespace.md @@ -185,7 +185,7 @@ scratch/happy> history b Note: The most recent namespace hash is immediately below this message. - ⊙ 1. #rkvfe5p8fu + ⊙ 1. #ugqniosnp0 + Adds / updates: @@ -195,7 +195,7 @@ scratch/happy> history b T.T - □ 2. #avlnmh0erc (start of history) + □ 2. #a7r726o5ut (start of history) ``` ## Namespace history diff --git a/unison-src/transcripts/idempotent/pattern-match-coverage.md b/unison-src/transcripts/idempotent/pattern-match-coverage.md index 90bf569876..144c546419 100644 --- a/unison-src/transcripts/idempotent/pattern-match-coverage.md +++ b/unison-src/transcripts/idempotent/pattern-match-coverage.md @@ -1286,5 +1286,5 @@ result f = ability GiveA a ability GiveB a - result : '{e, GiveA V, GiveB V} r ->{e} r + result : '{e, GiveB V, GiveA V} r ->{e} r ``` diff --git a/unison-src/transcripts/idempotent/propagate.md b/unison-src/transcripts/idempotent/propagate.md index c2861e3bb0..c4c24e2634 100644 --- a/unison-src/transcripts/idempotent/propagate.md +++ b/unison-src/transcripts/idempotent/propagate.md @@ -38,13 +38,13 @@ scratch/main> add scratch/main> find.verbose - 1. -- #uj8oalgadr2f52qloufah6t8vsvbc76oqijkotek87vooih7aqu44k20hrs34kartusapghp4jmfv6g1409peklv3r6a527qpk52soo + 1. -- #j743idicb1sf7udts85812agaml4rkfi3iss6lstvmvgufibd40blq5qtmoh9ndrtkvkaqkurn7npgc61ob8j2louj04j8slkppsl90 type Foo - 2. -- #uj8oalgadr2f52qloufah6t8vsvbc76oqijkotek87vooih7aqu44k20hrs34kartusapghp4jmfv6g1409peklv3r6a527qpk52soo#0 + 2. -- #j743idicb1sf7udts85812agaml4rkfi3iss6lstvmvgufibd40blq5qtmoh9ndrtkvkaqkurn7npgc61ob8j2louj04j8slkppsl90#0 Foo.Foo : Foo - 3. -- #j6hbm1gc2ak4f46b6705q90ld4bmhoi8etq2q45j081i9jgn95fvk3p6tjg67e7sm0021035i8qikmk4p6k845l5d00u26cos5731to + 3. -- #sd7apvqbpk3vl2aassq4gcckovohqrs05ne1g9ol0fb6gd227bp388osj7bg40kttt2o9f1kit9avlb94ep8q1ho3g284ursrplb4l0 fooToInt : Foo -> Int diff --git a/unison-src/transcripts/idempotent/transcript-parser-commands.md b/unison-src/transcripts/idempotent/transcript-parser-commands.md index 5782588136..ddc8e62dd6 100644 --- a/unison-src/transcripts/idempotent/transcript-parser-commands.md +++ b/unison-src/transcripts/idempotent/transcript-parser-commands.md @@ -30,7 +30,7 @@ scratch/main> add x : Nat ``` -``` unison :hide:error :scratch.u +``` unison :hide :error scratch.u z ``` diff --git a/unison-src/transcripts/idempotent/unique-type-churn.md b/unison-src/transcripts/idempotent/unique-type-churn.md index 25c06ea7d2..79b8a9684c 100644 --- a/unison-src/transcripts/idempotent/unique-type-churn.md +++ b/unison-src/transcripts/idempotent/unique-type-churn.md @@ -52,11 +52,11 @@ If the name stays the same, the churn is even prevented if the type is updated a scratch/main> names A Type - Hash: #uj8oalgadr + Hash: #j743idicb1 Names: A Term - Hash: #uj8oalgadr#0 + Hash: #j743idicb1#0 Names: A.A ``` @@ -88,11 +88,11 @@ scratch/main> update scratch/main> names A Type - Hash: #ufo5tuc7ho + Hash: #186m0i6upt Names: A Term - Hash: #ufo5tuc7ho#0 + Hash: #186m0i6upt#0 Names: A.A ``` @@ -126,10 +126,10 @@ scratch/main> update scratch/main> names A Type - Hash: #uj8oalgadr + Hash: #j743idicb1 Names: A Term - Hash: #uj8oalgadr#0 + Hash: #j743idicb1#0 Names: A.A ``` diff --git a/unison-src/transcripts/idempotent/update-type-add-constructor.md b/unison-src/transcripts/idempotent/update-type-add-constructor.md index 743bf42c9b..df8e58f663 100644 --- a/unison-src/transcripts/idempotent/update-type-add-constructor.md +++ b/unison-src/transcripts/idempotent/update-type-add-constructor.md @@ -56,17 +56,17 @@ scratch/main> update scratch/main> view Foo - type Foo = Bar Nat | Baz Nat Nat + type Foo = Baz Nat Nat | Bar Nat scratch/main> find.verbose - 1. -- #2sffq4apsq1cts53njcunj63fa8ohov4eqn77q14s77ajicajh4g28sq5s5ai33f2k6oh6o67aarnlpu7u7s4la07ag2er33epalsog + 1. -- #id3p6do8f7ssln9npa3gs3c2i8uors25ffts92pr4nsh9k9bn3no50e4d1b053c2d0vei64pbtcpdld9gk6drsvptnpfqr6tp8v4qh0 type Foo - 2. -- #2sffq4apsq1cts53njcunj63fa8ohov4eqn77q14s77ajicajh4g28sq5s5ai33f2k6oh6o67aarnlpu7u7s4la07ag2er33epalsog#0 + 2. -- #id3p6do8f7ssln9npa3gs3c2i8uors25ffts92pr4nsh9k9bn3no50e4d1b053c2d0vei64pbtcpdld9gk6drsvptnpfqr6tp8v4qh0#1 Foo.Bar : Nat -> Foo - 3. -- #2sffq4apsq1cts53njcunj63fa8ohov4eqn77q14s77ajicajh4g28sq5s5ai33f2k6oh6o67aarnlpu7u7s4la07ag2er33epalsog#1 + 3. -- #id3p6do8f7ssln9npa3gs3c2i8uors25ffts92pr4nsh9k9bn3no50e4d1b053c2d0vei64pbtcpdld9gk6drsvptnpfqr6tp8v4qh0#0 Foo.Baz : Nat -> Nat -> Foo ``` diff --git a/unison-src/transcripts/idempotent/update-type-add-field.md b/unison-src/transcripts/idempotent/update-type-add-field.md index b59d840ea0..83773a6e03 100644 --- a/unison-src/transcripts/idempotent/update-type-add-field.md +++ b/unison-src/transcripts/idempotent/update-type-add-field.md @@ -57,10 +57,10 @@ scratch/main> view Foo scratch/main> find.verbose - 1. -- #8fk6k0j208th1ia4vnjtoc5fomd6le540prec255svg71bcfga9dofrvoq1d7v6010d6b6em4q51p8st5c5juhrev72cnnel8ko3o1g + 1. -- #hlhjq1lf1cvfevkvb9d441kkubn0f6s43gvrd4gcff0r739vomehjnov4b3qe8506fb5bm8m5ba0sol9mbljgkk3gb2qt2u02v6i2vo type Foo - 2. -- #8fk6k0j208th1ia4vnjtoc5fomd6le540prec255svg71bcfga9dofrvoq1d7v6010d6b6em4q51p8st5c5juhrev72cnnel8ko3o1g#0 + 2. -- #hlhjq1lf1cvfevkvb9d441kkubn0f6s43gvrd4gcff0r739vomehjnov4b3qe8506fb5bm8m5ba0sol9mbljgkk3gb2qt2u02v6i2vo#0 Foo.Bar : Nat -> Nat -> Foo ``` diff --git a/unison-src/transcripts/idempotent/update-type-add-record-field.md b/unison-src/transcripts/idempotent/update-type-add-record-field.md index 46f48385a3..173d29b30d 100644 --- a/unison-src/transcripts/idempotent/update-type-add-record-field.md +++ b/unison-src/transcripts/idempotent/update-type-add-record-field.md @@ -72,28 +72,28 @@ scratch/main> view Foo scratch/main> find.verbose - 1. -- #05gh1dur4778dauh9slaofprc5356n47qpove0c1jl0birt2fcu301js8auu5vfr5bjfga9j8ikuk07ll9fu1gj3ehrp3basguhsd58 + 1. -- #m0tpa159pbsdld5ea0marnq9614dnmjjc72n1evi4bsk45a1hl84qprt6vdvejuuiuc3f5o23olc1t19tk1dt8mjobmr0chqc3svij8 type Foo - 2. -- #77mi33dv8ac2s90852khi35km5gsamhnpada8mai0k36obbttgg17qld719ospcs1ht9ctolg3pjsqs6qjnl3hfmu493rgsher73sc0 + 2. -- #16o21u2lli7rd8f3h4epnblpfk3h68gag99d5gicihcpk15dkv4m9601picg37ncsbg2e8j63tu7ebs40jrcoifs7f6nqrus3qnfgv0 Foo.bar : Foo -> Nat - 3. -- #7m1n2178r5u12jdnb6crcmanu2gm961kdvbjul5m6hta1s57avibsvk6p5g9efut8sennpgstbb8kf97eujbbuiplsoloa4cael7t90 + 3. -- #64v4pv4rvmnts82gbsb1u2dvgdu4eqq8leq37anqjrkq8s9c7ogrjahdotc36nrodva6ok1rs4ah5k09i7sb0clvcap2773k1t7thb8 Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo - 4. -- #ghuqoel4pao6v8e7un238i3e86vv7a7pnvgaq8m9s32edm1upgv35gri2iu32ipn9r4poli56r5kr3vtjfrltem696grfl75al4jkgg + 4. -- #bkfjhnu5jqv2m49hosd8g6m4e5u9ju4b1du90cji8s8hnaendvnep2a5cd085ejtu27c4lm3u7slamk52p86rubp211jc5c0qcut2l0 Foo.bar.set : Nat -> Foo -> Foo - 5. -- #p8emkm2s09n3nsd8ne5f6fro0vsldk8pn7n6rcf417anuvvun43qrk1ioofs6pdq4537eosao17c7ibvktktr3lfqglmj26gmbulmj0 + 5. -- #u394ule3vr1ab8q5nit6miktgpki9gj4nft5jfjsho6cflg94kf953mdhjj8s18e9j1525iv8l5ebjhebnuc01q51fl8ni5n9j0gs28 Foo.baz : Foo -> Int - 6. -- #0il9pl29jpe3fh6vp3qeqai73915k3qffhf4bgttrgsj000b9fgs3bqoj8ugjop6kdr04acc34m1bj7lf417tslfeva7dmmoqdu5hug + 6. -- #cbbi7mqcaqdlcl41uajb608b8fi5dfvc654rmd47mk9okpn1t3jltrf8psnn3g2tnr1ftctj753fjhco3ku1oapc664upo1h6eodfrg Foo.baz.modify : (Int ->{g} Int) -> Foo ->{g} Foo - 7. -- #87rjeqltvvd4adffsheqae62eefoge8p78pvnjdkc9q1stq20lhubvtpos0io4v3vhnol8nn2uollup97l4orq1fh2h12b0imeuuc58 + 7. -- #hhi45ik1245qq3g93586f998di8j5afvjamqr2m08auqq8ogqt4d01rejrse4qsl27381vnqnt8uffhgvnc0nk22o5uabimjhji4868 Foo.baz.set : Int -> Foo -> Foo - 8. -- #05gh1dur4778dauh9slaofprc5356n47qpove0c1jl0birt2fcu301js8auu5vfr5bjfga9j8ikuk07ll9fu1gj3ehrp3basguhsd58#0 + 8. -- #m0tpa159pbsdld5ea0marnq9614dnmjjc72n1evi4bsk45a1hl84qprt6vdvejuuiuc3f5o23olc1t19tk1dt8mjobmr0chqc3svij8#0 Foo.Foo : Nat -> Int -> Foo ``` diff --git a/unison-src/transcripts/idempotent/update-type-delete-constructor.md b/unison-src/transcripts/idempotent/update-type-delete-constructor.md index 1f6b205ce5..0457b42d0d 100644 --- a/unison-src/transcripts/idempotent/update-type-delete-constructor.md +++ b/unison-src/transcripts/idempotent/update-type-delete-constructor.md @@ -60,10 +60,10 @@ scratch/main> view Foo scratch/main> find.verbose - 1. -- #b509v3eg4kehsg29g6pvrogeb71ue32nm2fj9284n4i7lprsr7u9a7g6s695d09du0fsfti6rrsk1s62q5thpr1jjkqb3us3s0lrd60 + 1. -- #h88o5sirfn0a8f4o81sb012p2rha5h8r73n8bloc8qq94kqmltjq94iiep2e6dj7ppuulc8jce2f0vmddqp76nm0hqs9jh53s502v4g type Foo - 2. -- #b509v3eg4kehsg29g6pvrogeb71ue32nm2fj9284n4i7lprsr7u9a7g6s695d09du0fsfti6rrsk1s62q5thpr1jjkqb3us3s0lrd60#0 + 2. -- #h88o5sirfn0a8f4o81sb012p2rha5h8r73n8bloc8qq94kqmltjq94iiep2e6dj7ppuulc8jce2f0vmddqp76nm0hqs9jh53s502v4g#0 Foo.Bar : Nat -> Foo ``` diff --git a/unison-src/transcripts/idempotent/update-type-delete-record-field.md b/unison-src/transcripts/idempotent/update-type-delete-record-field.md index ec2417d02b..c15cd9122b 100644 --- a/unison-src/transcripts/idempotent/update-type-delete-record-field.md +++ b/unison-src/transcripts/idempotent/update-type-delete-record-field.md @@ -78,28 +78,28 @@ scratch/main> view Foo scratch/main> find.verbose - 1. -- #05gh1dur4778dauh9slaofprc5356n47qpove0c1jl0birt2fcu301js8auu5vfr5bjfga9j8ikuk07ll9fu1gj3ehrp3basguhsd58 + 1. -- #m0tpa159pbsdld5ea0marnq9614dnmjjc72n1evi4bsk45a1hl84qprt6vdvejuuiuc3f5o23olc1t19tk1dt8mjobmr0chqc3svij8 type Foo - 2. -- #77mi33dv8ac2s90852khi35km5gsamhnpada8mai0k36obbttgg17qld719ospcs1ht9ctolg3pjsqs6qjnl3hfmu493rgsher73sc0 + 2. -- #16o21u2lli7rd8f3h4epnblpfk3h68gag99d5gicihcpk15dkv4m9601picg37ncsbg2e8j63tu7ebs40jrcoifs7f6nqrus3qnfgv0 Foo.bar : Foo -> Nat - 3. -- #7m1n2178r5u12jdnb6crcmanu2gm961kdvbjul5m6hta1s57avibsvk6p5g9efut8sennpgstbb8kf97eujbbuiplsoloa4cael7t90 + 3. -- #64v4pv4rvmnts82gbsb1u2dvgdu4eqq8leq37anqjrkq8s9c7ogrjahdotc36nrodva6ok1rs4ah5k09i7sb0clvcap2773k1t7thb8 Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo - 4. -- #ghuqoel4pao6v8e7un238i3e86vv7a7pnvgaq8m9s32edm1upgv35gri2iu32ipn9r4poli56r5kr3vtjfrltem696grfl75al4jkgg + 4. -- #bkfjhnu5jqv2m49hosd8g6m4e5u9ju4b1du90cji8s8hnaendvnep2a5cd085ejtu27c4lm3u7slamk52p86rubp211jc5c0qcut2l0 Foo.bar.set : Nat -> Foo -> Foo - 5. -- #p8emkm2s09n3nsd8ne5f6fro0vsldk8pn7n6rcf417anuvvun43qrk1ioofs6pdq4537eosao17c7ibvktktr3lfqglmj26gmbulmj0 + 5. -- #u394ule3vr1ab8q5nit6miktgpki9gj4nft5jfjsho6cflg94kf953mdhjj8s18e9j1525iv8l5ebjhebnuc01q51fl8ni5n9j0gs28 Foo.baz : Foo -> Int - 6. -- #0il9pl29jpe3fh6vp3qeqai73915k3qffhf4bgttrgsj000b9fgs3bqoj8ugjop6kdr04acc34m1bj7lf417tslfeva7dmmoqdu5hug + 6. -- #cbbi7mqcaqdlcl41uajb608b8fi5dfvc654rmd47mk9okpn1t3jltrf8psnn3g2tnr1ftctj753fjhco3ku1oapc664upo1h6eodfrg Foo.baz.modify : (Int ->{g} Int) -> Foo ->{g} Foo - 7. -- #87rjeqltvvd4adffsheqae62eefoge8p78pvnjdkc9q1stq20lhubvtpos0io4v3vhnol8nn2uollup97l4orq1fh2h12b0imeuuc58 + 7. -- #hhi45ik1245qq3g93586f998di8j5afvjamqr2m08auqq8ogqt4d01rejrse4qsl27381vnqnt8uffhgvnc0nk22o5uabimjhji4868 Foo.baz.set : Int -> Foo -> Foo - 8. -- #05gh1dur4778dauh9slaofprc5356n47qpove0c1jl0birt2fcu301js8auu5vfr5bjfga9j8ikuk07ll9fu1gj3ehrp3basguhsd58#0 + 8. -- #m0tpa159pbsdld5ea0marnq9614dnmjjc72n1evi4bsk45a1hl84qprt6vdvejuuiuc3f5o23olc1t19tk1dt8mjobmr0chqc3svij8#0 Foo.Foo : Nat -> Int -> Foo ``` diff --git a/unison-src/transcripts/idempotent/update-type-missing-constructor.md b/unison-src/transcripts/idempotent/update-type-missing-constructor.md index f88af7b953..e7198191bd 100644 --- a/unison-src/transcripts/idempotent/update-type-missing-constructor.md +++ b/unison-src/transcripts/idempotent/update-type-missing-constructor.md @@ -52,7 +52,7 @@ unique type Foo = Bar Nat Nat ``` ucm :error scratch/main> view Foo - type Foo = #b509v3eg4k#0 Nat + type Foo = #5mod0n8ps2#0 Nat scratch/main> update diff --git a/unison-src/transcripts/idempotent/update-type-turn-constructor-into-smart-constructor.md b/unison-src/transcripts/idempotent/update-type-turn-constructor-into-smart-constructor.md index baf5d34cd9..b96ea2bc1d 100644 --- a/unison-src/transcripts/idempotent/update-type-turn-constructor-into-smart-constructor.md +++ b/unison-src/transcripts/idempotent/update-type-turn-constructor-into-smart-constructor.md @@ -70,16 +70,16 @@ scratch/main> view Foo scratch/main> find.verbose - 1. -- #b509v3eg4kehsg29g6pvrogeb71ue32nm2fj9284n4i7lprsr7u9a7g6s695d09du0fsfti6rrsk1s62q5thpr1jjkqb3us3s0lrd60 + 1. -- #oebc8v8v9lob5bnq7go1pjhfjbtnh8dmfhontua90t3mji0cl91t1dqaece9quofrk1vsbq6g0ukfigoi0vmvc01v8roceppejlgbs8 type Foo - 2. -- #36rn6jqt1k5jccb3c7vagp3jam74dngr92kgcntqhs6dbkua54verfert2i6hsku6uitt9s2jvt1msric0tgemal52d5apav6akn25o + 2. -- #gl18p1lnbeari67ohdt9n46usnvsl59a6up1lhd9r808pqb7tt5edsf65o98bqcvb529mfm7q631ciuv2t5nqnde1i7b9t5mlu1drto Foo.Bar : Nat -> Foo - 3. -- #b509v3eg4kehsg29g6pvrogeb71ue32nm2fj9284n4i7lprsr7u9a7g6s695d09du0fsfti6rrsk1s62q5thpr1jjkqb3us3s0lrd60#0 + 3. -- #oebc8v8v9lob5bnq7go1pjhfjbtnh8dmfhontua90t3mji0cl91t1dqaece9quofrk1vsbq6g0ukfigoi0vmvc01v8roceppejlgbs8#0 Foo.internal.Bar : Nat -> Foo - 4. -- #204frdcl0iid1ujkkfbkc6b3v7cgqp56h1q3duc46i5md6qb4m6am1fqbceb335u87l05gkdnaa7fjn4alj1diukgme63e41lh072l8 + 4. -- #td96hudai64mf0qgtusc70ehv98krs10jghdipjluc6cp4j8ac65msrt3tji18enpm2tm8d8h2qcf3parke19g7s17ipkd925m3061g makeFoo : Nat -> Foo ``` diff --git a/unison-src/transcripts/idempotent/update-type-turn-non-record-into-record.md b/unison-src/transcripts/idempotent/update-type-turn-non-record-into-record.md index ed6fd0aa95..1801932fa7 100644 --- a/unison-src/transcripts/idempotent/update-type-turn-non-record-into-record.md +++ b/unison-src/transcripts/idempotent/update-type-turn-non-record-into-record.md @@ -63,19 +63,19 @@ scratch/main> view Foo scratch/main> find.verbose - 1. -- #b509v3eg4kehsg29g6pvrogeb71ue32nm2fj9284n4i7lprsr7u9a7g6s695d09du0fsfti6rrsk1s62q5thpr1jjkqb3us3s0lrd60 + 1. -- #5mod0n8ps2emue478fdroo6adp4ovt41qogtmduta8vgv1v8mi8ep2ho0rc1mg699j1feojmv0oe9ndbul5t64menchhnklpgji45o0 type Foo - 2. -- #ovhevqfin94qhq5fu0mujfi20mbpvg5mh4vsfklrohp84cch4lhvrn5p29cnbsqfm92l7bt8c1vpjooh72a0psbddvvten4gq2sipag + 2. -- #pshsb3s03nqe194ks3ap3kid0gpb13d68u83gss8vtmbfqma97f84b4vqf362r8gieulqnbfidvh9idkgp6k7mllmss92bh9ebqmolo Foo.bar : Foo -> Nat - 3. -- #as72md2u70e0u9s2ig2ug7jvlbrk1mubo8qlfokpuvgusg35svh05r7nsj27sqo5edeghjnk8g8259fi4ismse736v4n5ojrb3o2le8 + 3. -- #184mc2vauvn8197ecedvus5ubj787dgav6cjkvqqnohej8f997ku7iicurnkvlcqtlv29mjad0mjr3td241q7b0b0kg0i9v4n3qq7vo Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo - 4. -- #5cbctoor75nbtn4ppp10qm1i25gqt2lgth3itqa0lloib32je4ijfj2n3qcdfhmdcnbgum2jg46opntlohv7ladun3dmefl1ucgobeg + 4. -- #sc08708c9s5mhtg6r1obh2mckvjhc5pf2e83lafrkrjrpkikh9kn09vag7kbugcnit50ak8vgr1100am6iqo4ln75uq4dck9pasvnv8 Foo.bar.set : Nat -> Foo -> Foo - 5. -- #b509v3eg4kehsg29g6pvrogeb71ue32nm2fj9284n4i7lprsr7u9a7g6s695d09du0fsfti6rrsk1s62q5thpr1jjkqb3us3s0lrd60#0 + 5. -- #5mod0n8ps2emue478fdroo6adp4ovt41qogtmduta8vgv1v8mi8ep2ho0rc1mg699j1feojmv0oe9ndbul5t64menchhnklpgji45o0#0 Foo.Foo : Nat -> Foo ``` diff --git a/unison-src/transcripts/idempotent/update-type-with-dependent-type.md b/unison-src/transcripts/idempotent/update-type-with-dependent-type.md index dea13297d2..83c8812f72 100644 --- a/unison-src/transcripts/idempotent/update-type-with-dependent-type.md +++ b/unison-src/transcripts/idempotent/update-type-with-dependent-type.md @@ -68,16 +68,16 @@ scratch/main> view Baz scratch/main> find.verbose - 1. -- #34msh9satlfog576493eo9pkjn6aj7d8fj6jfheglvgr5s39iptb81649bpkad1lqraheqb8em9ms551k01oternhknc4m7jicgtk08 + 1. -- #1uosg6rv85ql7rbohtfvqqacgjl5pp2faj0t3k3dkrtn0t3jqdh2m2om8earv0jh8m8j86vv6bv1h17jl8a2lfa857pm6n27hnisi1g type Baz - 2. -- #34msh9satlfog576493eo9pkjn6aj7d8fj6jfheglvgr5s39iptb81649bpkad1lqraheqb8em9ms551k01oternhknc4m7jicgtk08#0 + 2. -- #1uosg6rv85ql7rbohtfvqqacgjl5pp2faj0t3k3dkrtn0t3jqdh2m2om8earv0jh8m8j86vv6bv1h17jl8a2lfa857pm6n27hnisi1g#0 Baz.Qux : Foo -> Baz - 3. -- #8fk6k0j208th1ia4vnjtoc5fomd6le540prec255svg71bcfga9dofrvoq1d7v6010d6b6em4q51p8st5c5juhrev72cnnel8ko3o1g + 3. -- #hlhjq1lf1cvfevkvb9d441kkubn0f6s43gvrd4gcff0r739vomehjnov4b3qe8506fb5bm8m5ba0sol9mbljgkk3gb2qt2u02v6i2vo type Foo - 4. -- #8fk6k0j208th1ia4vnjtoc5fomd6le540prec255svg71bcfga9dofrvoq1d7v6010d6b6em4q51p8st5c5juhrev72cnnel8ko3o1g#0 + 4. -- #hlhjq1lf1cvfevkvb9d441kkubn0f6s43gvrd4gcff0r739vomehjnov4b3qe8506fb5bm8m5ba0sol9mbljgkk3gb2qt2u02v6i2vo#0 Foo.Bar : Nat -> Nat -> Foo ``` diff --git a/unison-src/transcripts/merge.md b/unison-src/transcripts/merge.md index 6b759f44ce..7bbbd16cf6 100644 --- a/unison-src/transcripts/merge.md +++ b/unison-src/transcripts/merge.md @@ -870,7 +870,7 @@ scratch/alice> delete.term Foo.Bar.Baz scratch/alice> delete.term Foo.Bar.Qux ``` -``` unison :hide:all +``` unison :hide-all Foo.Bar.Baz : Nat Foo.Bar.Baz = 100 @@ -1301,7 +1301,7 @@ Alice's branch: scratch/main> branch alice ``` -``` unison :hide:all +``` unison :hide-all unique type Foo = Bar ``` @@ -1315,7 +1315,7 @@ Bob's branch: scratch/main> branch bob ``` -``` unison :hide:all +``` unison :hide-all bob : Nat bob = 101 ``` diff --git a/unison-src/transcripts/merge.output.md b/unison-src/transcripts/merge.output.md index 288ec046e2..e12726898d 100644 --- a/unison-src/transcripts/merge.output.md +++ b/unison-src/transcripts/merge.output.md @@ -1588,7 +1588,7 @@ scratch/bob> move.term Foo.Bar.Qux Foo.Bar.Hello ``` ucm scratch/bob> view Foo.Bar - type Foo.Bar = Baz Nat | Hello Nat Nat + type Foo.Bar = Hello Nat Nat | Baz Nat ``` At this point, Bob and alice have both updated the name `Foo.Bar.Hello` in different ways, so that's a conflict. Therefore, Bob's entire type (`Foo.Bar` with constructors `Foo.Bar.Baz` and `Foo.Bar.Hello`) gets rendered into the scratch file. @@ -1635,7 +1635,7 @@ Foo.Bar.Hello : Nat Foo.Bar.Hello = 18 -- scratch/bob -type Foo.Bar = Baz Nat | Hello Nat Nat +type Foo.Bar = Hello Nat Nat | Baz Nat ``` diff --git a/unison-src/transcripts/no-hash-in-term-declaration.md b/unison-src/transcripts/no-hash-in-term-declaration.md index 493c2f32ce..85ef6c0de2 100644 --- a/unison-src/transcripts/no-hash-in-term-declaration.md +++ b/unison-src/transcripts/no-hash-in-term-declaration.md @@ -2,7 +2,7 @@ There should not be hashes in the names used in term declarations, either in the type signature or the type definition. -``` unison :hide:all:error +``` unison :hide-all :error x##Nat : Int -> Int -> Boolean x##Nat = 5 ``` diff --git a/unison-syntax/package.yaml b/unison-syntax/package.yaml index 77a4c724b3..0742346f40 100644 --- a/unison-syntax/package.yaml +++ b/unison-syntax/package.yaml @@ -39,6 +39,7 @@ tests: - base - code-page - easytest + - free - megaparsec - unison-core1 - unison-prelude diff --git a/unison-syntax/test/Unison/Test/Doc.hs b/unison-syntax/test/Unison/Test/Doc.hs index 50e7eb10de..cc4bedf4ce 100644 --- a/unison-syntax/test/Unison/Test/Doc.hs +++ b/unison-syntax/test/Unison/Test/Doc.hs @@ -1,5 +1,6 @@ module Unison.Test.Doc (test) where +import Control.Comonad.Trans.Cofree (CofreeF ((:<))) import Data.Bifunctor (first) import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Text (Text) @@ -137,7 +138,7 @@ t s expected = (crash . P.errorBundlePretty) ( \actual -> let expected' = Doc.UntitledSection $ embed <$> expected - actual' = cata (\(_ :<< top) -> embed $ first (cata \(_ :<< leaf) -> embed leaf) top) <$> actual + actual' = cata (\(_ :< top) -> embed $ first (cata \(_ :< leaf) -> embed leaf) top) <$> actual in if actual' == expected' then ok else do diff --git a/unison-syntax/unison-syntax.cabal b/unison-syntax/unison-syntax.cabal index 389ca06413..8a3e2948ef 100644 --- a/unison-syntax/unison-syntax.cabal +++ b/unison-syntax/unison-syntax.cabal @@ -130,6 +130,7 @@ test-suite syntax-tests base , code-page , easytest + , free , megaparsec , text , unison-core1