mirror of
https://github.com/unisonweb/unison.git
synced 2024-11-12 04:34:38 +03:00
Merge remote-tracking branch 'origin/wip/rt1' into wip/overhaul-search
# Conflicts: # parser-typechecker/src/Unison/Codebase/CommandLine.hs # parser-typechecker/unison/Main.hs
This commit is contained in:
Arya Irani
commit
42ab32cb17
152
IO.u
Normal file
152
IO.u
Normal file
@ -0,0 +1,152 @@
|
||||
-- Handles are unique identifiers.
|
||||
-- The implementation of IO in the runtime will supply Haskell
|
||||
-- file handles and map those to Unison handles.
|
||||
-- A pure implementation of I/O might use some kind of pure supply
|
||||
-- of unique IDs instead.
|
||||
type Handle = Handle Text
|
||||
|
||||
-- Ditto for sockets
|
||||
type Socket = Socket Text
|
||||
|
||||
-- Builtin handles: standard in, out, error
|
||||
-- stdin: Handle
|
||||
-- stdout: Handle
|
||||
-- stderr: Handle
|
||||
|
||||
-- IO Modes from the Haskell API
|
||||
type IOMode = Read | Write | Append | ReadWrite
|
||||
|
||||
-- IO error types from the Haskell API
|
||||
type IOErrorType
|
||||
= AlreadyExists
|
||||
| NoSuchThing
|
||||
| ResourceBusy
|
||||
| ResourceExhausted
|
||||
| EOF
|
||||
| IllegalOperation
|
||||
| PermissionDenied
|
||||
| UserError
|
||||
|
||||
type ErrorLocation = ErrorLocation Text
|
||||
type ErrorDescription = ErrorDescription Text
|
||||
type FilePath = FilePath Text
|
||||
|
||||
type IOError =
|
||||
IOError
|
||||
(Optional Handle)
|
||||
IOErrorType
|
||||
ErrorLocation
|
||||
ErrorDescription
|
||||
(Optional FilePath)
|
||||
|
||||
type SeekMode = Absolute | Relative | FromEnd
|
||||
|
||||
-- If the buffer size is not specified,
|
||||
-- use an implementation-specific size.
|
||||
type BufferMode = Line | Block (Optional Nat)
|
||||
|
||||
type EpochTime = EpochTime Nat
|
||||
|
||||
-- Either a host name e.g., "unisonweb.org" or a numeric host address
|
||||
-- string consisting of a dotted decimal IPv4 address or an IPv6 address
|
||||
-- e.g., "192.168.0.1".
|
||||
type HostName = HostName Text
|
||||
|
||||
type PortNumber = Nat
|
||||
|
||||
-- Represents a 32-bit host address
|
||||
type HostAddress = HostAddress Int
|
||||
|
||||
-- Internet protocol v4 socket address
|
||||
type SocketAddress = SocketAddress HostAddress PortNumber
|
||||
|
||||
|
||||
ability IO where
|
||||
|
||||
-- Basic file IO
|
||||
openFile : FilePath -> IOMode ->{IO} Handle
|
||||
closeFile : Handle ->{IO} ()
|
||||
isEOF : Handle ->{IO} Boolean
|
||||
isFileOpen : Handle ->{IO} Boolean
|
||||
|
||||
-- Text input and output
|
||||
|
||||
--getChar : Handle ->{IO} Char
|
||||
getLine : Handle ->{IO} Text
|
||||
-- Get the entire contents of the file as text
|
||||
getText : Handle ->{IO} Text
|
||||
-- putChar : Handle -> Char ->{IO} ()
|
||||
putText : Handle -> Text ->{IO} ()
|
||||
|
||||
-- Handling I/O errors.
|
||||
-- Question: can we do better?
|
||||
throw : IOError ->{IO} a
|
||||
catch : '{IO} a -> (IOError ->{IO} a) ->{IO} a
|
||||
|
||||
-- File positioning
|
||||
isSeekable : Handle ->{IO} Boolean
|
||||
seek : Handle -> SeekMode -> Int ->{IO} ()
|
||||
position : Handle ->{IO} Int
|
||||
|
||||
-- File buffering
|
||||
getBuffering : Handle ->{IO} (Optional BufferMode)
|
||||
setBuffering : Handle -> Optional BufferMode ->{IO} ()
|
||||
|
||||
-- Should we expose mutable arrays for byte buffering?
|
||||
-- Inclined to say no, although that sounds a lot like
|
||||
-- a decision to just be slow.
|
||||
-- We'll need a byte buffer manipulation library in that case.
|
||||
|
||||
-- getBytes : Handle -> Nat ->{IO} Bytes
|
||||
-- putBytes : Handle -> Bytes ->{IO} ()
|
||||
|
||||
-- getBytes : Handle -> Nat -> ByteArray ->{IO} Nat
|
||||
-- putBytes : Handle -> Nat -> ByteArray ->{IO} ()
|
||||
|
||||
systemTime : {IO} EpochTime
|
||||
|
||||
|
||||
-- File system operations
|
||||
getCurrentDirectory : {IO} FilePath
|
||||
setCurrentDirectory : FilePath ->{IO} ()
|
||||
directoryContents : FilePath ->{IO} [FilePath]
|
||||
fileExists : FilePath -> {IO} Boolean
|
||||
isDirectory : FilePath ->{IO} Boolean
|
||||
createDirectory : FilePath ->{IO} ()
|
||||
removeDirectory : FilePath ->{IO} ()
|
||||
renameDirectory : FilePath -> FilePath -> {IO} ()
|
||||
removeFile : FilePath ->{IO} ()
|
||||
renameFile : FilePath -> FilePath ->{IO} ()
|
||||
getFileTimestamp : FilePath ->{IO} EpochTime
|
||||
getFileSize : FilePath ->{IO} Nat
|
||||
|
||||
|
||||
-- Network I/O
|
||||
|
||||
-- Glossing over address families (ipv4, ipv6),
|
||||
-- and socket types (stream, raw, etc)
|
||||
|
||||
-- Creates a socket and binds it to a the given local port
|
||||
serverSocket : SocketAddress -> {IO} Socket
|
||||
|
||||
-- Creates a socket connected to the given remote address
|
||||
clientSocket : SocketAddress -> {IO} Socket
|
||||
|
||||
socketToHandle : Socket ->{IO} Handle
|
||||
handleToSocket : Handle ->{IO} Socket
|
||||
closeSocket : Socket ->{IO} ()
|
||||
|
||||
-- Accept a connection on a socket.
|
||||
-- Returns a socket that can send and receive data on a new connection,
|
||||
-- together with the remote host information.
|
||||
accept : Socket ->{IO} (Socket, SocketAddress)
|
||||
|
||||
-- Returns the number of bytes actually sent
|
||||
-- send : Socket -> Bytes ->{IO} Int
|
||||
|
||||
-- scatter/gather mode network I/O
|
||||
-- sendMany : Socket -> [Bytes] ->{IO} Int
|
||||
|
||||
-- Read the spefified number of bytes from the socket.
|
||||
-- receive : Socket -> Int ->{IO} Bytes
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
The Unison platform
|
||||
The Unison language
|
||||
======
|
||||
|
||||
[](https://travis-ci.org/unisonweb/unison)
|
||||
|
||||
@ -238,5 +238,7 @@ builtins0 = Map.fromList $
|
||||
, ("Sequence.at", "Nat -> [a] -> Optional a")
|
||||
|
||||
, ("Debug.watch", "Text -> a -> a")
|
||||
, ("Effect.pure", "a -> Effect e a") -- Effect ambient e a
|
||||
, ("Effect.bind", "'{e} a -> (a ->{ambient} b) -> Effect e a") -- Effect ambient e a
|
||||
]
|
||||
]
|
||||
|
||||
@ -144,6 +144,8 @@ data Input
|
||||
-- resolve update conflicts
|
||||
| ChooseUpdateForTermI Referent Referent
|
||||
| ChooseUpdateForTypeI Reference Reference
|
||||
-- execute an IO object with arguments
|
||||
-- | ExecuteI Name [String]
|
||||
-- other
|
||||
| SlurpFileI AllowUpdates
|
||||
| ListBranchesI
|
||||
@ -208,7 +210,10 @@ data Output v
|
||||
| ParseErrors Text [Parser.Err v]
|
||||
| TypeErrors Text PPE.PrettyPrintEnv [Context.ErrorNote v Ann]
|
||||
| DisplayConflicts Branch0
|
||||
| Evaluated SourceFileContents PPE.PrettyPrintEnv (Map v (Ann, Term v (), Runtime.IsCacheHit))
|
||||
| Evaluated SourceFileContents
|
||||
PPE.PrettyPrintEnv
|
||||
[(v, Term v ())]
|
||||
(Map v (Ann, Term v (), Runtime.IsCacheHit))
|
||||
| Typechecked SourceName PPE.PrettyPrintEnv (UF.TypecheckedUnisonFile v Ann)
|
||||
| FileChangeEvent SourceName Text
|
||||
| DisplayDefinitions (Maybe FilePath) PPE.PrettyPrintEnv
|
||||
@ -296,7 +301,7 @@ data Command i v a where
|
||||
-- of the same watches instantaneous.
|
||||
Evaluate :: Branch
|
||||
-> UF.UnisonFile v Ann
|
||||
-> Command i v (Map v
|
||||
-> Command i v ([(v, Term v ())], Map v
|
||||
(Ann, Reference, Term v (), Term v (), Runtime.IsCacheHit))
|
||||
|
||||
-- Load definitions from codebase:
|
||||
@ -349,6 +354,8 @@ data Command i v a where
|
||||
|
||||
Propagate :: Branch -> Command i v Branch
|
||||
|
||||
-- Execute :: Reference.Id -> Command i v (IO ())
|
||||
|
||||
data Outcome
|
||||
-- New definition that was added to the branch
|
||||
= Added
|
||||
@ -399,8 +406,10 @@ outcomes okToUpdate b file = let
|
||||
[] -> (r0, Added)
|
||||
referents ->
|
||||
if not (okToUpdate n) then (r0, CouldntUpdate)
|
||||
else if length referents > 1 then (r0, CouldntUpdateConflicted)
|
||||
else if any Referent.isConstructor referents then (r0, TermExistingConstructorCollision)
|
||||
else if length referents > 1
|
||||
then (r0, CouldntUpdateConflicted)
|
||||
else if any Referent.isConstructor referents
|
||||
then (r0, TermExistingConstructorCollision)
|
||||
else (r0, Updated)
|
||||
-- It's a type
|
||||
Left _ -> let
|
||||
@ -426,12 +435,16 @@ outcomes okToUpdate b file = let
|
||||
|
||||
outcomes0terms = map termOutcome (Map.toList $ UF.hashTerms file)
|
||||
termOutcome (v, (r, _, _)) = outcome0 (Name.unsafeFromVar v) (Right r) []
|
||||
outcomes0types
|
||||
= map typeOutcome (Map.toList . fmap (second Right) $ UF.dataDeclarations' file)
|
||||
++ map typeOutcome (Map.toList . fmap (second Left) $ UF.effectDeclarations' file)
|
||||
typeOutcome (v, (r, dd)) = outcome0 (Name.unsafeFromVar v) (Left r) $ ctorNames v r dd
|
||||
ctorNames v r (Left e) = Map.keys $ Names.termNames (DD.effectDeclToNames v r e)
|
||||
ctorNames v r (Right dd) = Map.keys $ Names.termNames (DD.dataDeclToNames v r dd)
|
||||
outcomes0types =
|
||||
map typeOutcome (Map.toList . fmap (second Right) $ UF.dataDeclarations' file)
|
||||
++ map typeOutcome
|
||||
(Map.toList . fmap (second Left) $ UF.effectDeclarations' file)
|
||||
typeOutcome (v, (r, dd)) =
|
||||
outcome0 (Name.unsafeFromVar v) (Left r) $ ctorNames v r dd
|
||||
ctorNames v r (Left e) =
|
||||
Map.keys $ Names.termNames (DD.effectDeclToNames v r e)
|
||||
ctorNames v r (Right dd) =
|
||||
Map.keys $ Names.termNames (DD.dataDeclToNames v r dd)
|
||||
outcomes0 = outcomes0terms ++ outcomes0types
|
||||
in removeTransitive (UF.dependencies' file) outcomes0
|
||||
|
||||
|
||||
@ -129,7 +129,7 @@ loop s = Free.unfold' (evalStateT (maybe (Left ()) Right <$> runMaybeT (go *> ge
|
||||
-- A unison file has changed
|
||||
Just unisonFile -> do
|
||||
eval (Notify $ Typechecked sourceName errorEnv unisonFile)
|
||||
e <-
|
||||
(bindings, e) <-
|
||||
eval
|
||||
( Evaluate (view currentBranch s)
|
||||
$ UF.discardTypes unisonFile
|
||||
@ -140,7 +140,9 @@ loop s = Free.unfold' (evalStateT (maybe (Left ()) Right <$> runMaybeT (go *> ge
|
||||
-- with all the (hash, eval) pairs, even if it's just an
|
||||
-- in-memory cache
|
||||
eval . Notify $ Evaluated text
|
||||
(Branch.prettyPrintEnv $ Branch.head currentBranch') e'
|
||||
(Branch.prettyPrintEnv $ Branch.head currentBranch')
|
||||
bindings
|
||||
e'
|
||||
latestFile .= Just (Text.unpack sourceName, False)
|
||||
latestTypecheckedFile .= Just unisonFile
|
||||
Right input -> case input of
|
||||
@ -263,6 +265,8 @@ loop s = Free.unfold' (evalStateT (maybe (Left ()) Right <$> runMaybeT (go *> ge
|
||||
_ <- eval $ MergeBranch currentBranchName' b
|
||||
_ <- success
|
||||
currentBranch .= b
|
||||
-- ExecuteI name args ->
|
||||
|
||||
QuitI -> quit
|
||||
where
|
||||
success = respond $ Success input
|
||||
|
||||
@ -10,7 +10,6 @@ import Data.Functor ( void )
|
||||
import Data.Map ( Map )
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import Control.Monad.IO.Class ( MonadIO )
|
||||
import qualified Unison.Codebase.CodeLookup as CL
|
||||
import Unison.UnisonFile ( UnisonFile )
|
||||
import qualified Unison.Term as Term
|
||||
@ -23,13 +22,13 @@ import qualified Unison.Reference as Reference
|
||||
import qualified Unison.UnisonFile as UF
|
||||
|
||||
data Runtime v = Runtime
|
||||
{ terminate :: forall m. MonadIO m => m ()
|
||||
{ terminate :: IO ()
|
||||
, evaluate
|
||||
:: forall a m
|
||||
. (MonadIO m, Monoid a)
|
||||
=> CL.CodeLookup m v a
|
||||
:: forall a
|
||||
. Monoid a
|
||||
=> CL.CodeLookup IO v a
|
||||
-> AnnotatedTerm v a
|
||||
-> m (Term v)
|
||||
-> IO (Term v)
|
||||
}
|
||||
|
||||
type IsCacheHit = Bool
|
||||
@ -42,46 +41,57 @@ type IsCacheHit = Bool
|
||||
-- Note: The definitions in the file are hashed and looked up in
|
||||
-- `evaluationCache`. If that returns a result, evaluation of that definition
|
||||
-- can be skipped.
|
||||
evaluateWatches :: forall m v a . (Var v, MonadIO m)
|
||||
=> CL.CodeLookup m v a
|
||||
-> (Reference -> m (Maybe (Term v)))
|
||||
-> Runtime v
|
||||
-> UnisonFile v a
|
||||
-> m (Map v (a, Reference, Term v, Term v, IsCacheHit))
|
||||
evaluateWatches
|
||||
:: forall v a
|
||||
. Var v
|
||||
=> CL.CodeLookup IO v a
|
||||
-> (Reference -> IO (Maybe (Term v)))
|
||||
-> Runtime v
|
||||
-> UnisonFile v a
|
||||
-> IO
|
||||
( [(v, Term v)]
|
||||
-- Map watchName (loc, hash, expression, value, isHit)
|
||||
, Map v (a, Reference, Term v, Term v, IsCacheHit)
|
||||
)
|
||||
-- IO (bindings :: [v,Term v], map :: ^^^)
|
||||
evaluateWatches code evaluationCache rt uf = do
|
||||
-- 1. compute hashes for everything in the file
|
||||
let
|
||||
m :: Map v (Reference, AnnotatedTerm v a)
|
||||
m = Term.hashComponents (Map.fromList (UF.terms uf <> UF.watches uf))
|
||||
watches = Set.fromList (fst <$> UF.watches uf)
|
||||
unann = Term.amap (const ())
|
||||
let m :: Map v (Reference, AnnotatedTerm v a)
|
||||
m = Term.hashComponents (Map.fromList (UF.terms uf <> UF.watches uf))
|
||||
watches = Set.fromList (fst <$> UF.watches uf)
|
||||
unann = Term.amap (const ())
|
||||
-- 2. use the cache to lookup things already computed
|
||||
m' <- fmap Map.fromList . for (Map.toList m) $ \(v, (r, t)) -> do
|
||||
o <- evaluationCache r
|
||||
case o of Nothing -> pure (v, (r, ABT.annotation t, unann t, False))
|
||||
Just t' -> pure (v, (r, ABT.annotation t, t', True))
|
||||
case o of
|
||||
Nothing -> pure (v, (r, ABT.annotation t, unann t, False))
|
||||
Just t' -> pure (v, (r, ABT.annotation t, t', True))
|
||||
-- 3. create a big ol' let rec whose body is a big tuple of all watches
|
||||
let
|
||||
rv :: Map Reference v
|
||||
rv = Map.fromList [(r,v) | (v, (r,_)) <- Map.toList m ]
|
||||
bindings :: [(v, Term v)]
|
||||
bindings = [ (v, unref rv b) | (v, (_,_,b,_)) <- Map.toList m' ]
|
||||
watchVars = [ Term.var() v | v <- toList watches ]
|
||||
bigOl'LetRec = Term.letRec' True bindings (Term.tuple watchVars)
|
||||
cl = void $ CL.fromUnisonFile uf <> code
|
||||
let rv :: Map Reference v
|
||||
rv = Map.fromList [ (r, v) | (v, (r, _)) <- Map.toList m ]
|
||||
bindings :: [(v, Term v)]
|
||||
bindings = [ (v, unref rv b) | (v, (_, _, b, _)) <- Map.toList m' ]
|
||||
watchVars = [ Term.var () v | v <- toList watches ]
|
||||
bigOl'LetRec = Term.letRec' True bindings (Term.tuple watchVars)
|
||||
cl = void $ CL.fromUnisonFile uf <> code
|
||||
-- 4. evaluate it and get all the results out of the tuple, then
|
||||
-- create the result Map
|
||||
out <- evaluate rt cl bigOl'LetRec
|
||||
case out of
|
||||
Term.Tuple' results -> pure $
|
||||
let go eval (ref, a, uneval, isHit) = (a, ref, uneval, eval, isHit)
|
||||
in Map.intersectionWith go (Map.fromList (toList watches `zip` results)) m'
|
||||
_ -> fail $ "Evaluation should produce a tuple, but gave: " ++ show out
|
||||
where
|
||||
let
|
||||
(bindings, results) = case out of
|
||||
Term.Tuple' results -> (mempty, results)
|
||||
Term.LetRecNamed' bs (Term.Tuple' results) -> (bs, results)
|
||||
_ -> fail $ "Evaluation should produce a tuple, but gave: " ++ show out
|
||||
let go eval (ref, a, uneval, isHit) =
|
||||
(a, ref, uneval, Term.etaNormalForm eval, isHit)
|
||||
watchMap =
|
||||
Map.intersectionWith go (Map.fromList (toList watches `zip` results)) m'
|
||||
pure (bindings, watchMap)
|
||||
where
|
||||
-- unref :: Map Reference v -> AnnotatedTerm v a -> AnnotatedTerm v a
|
||||
unref rv t = ABT.visitPure go t
|
||||
where
|
||||
go t@(Term.Ref' r@(Reference.DerivedId _)) = case Map.lookup r rv of
|
||||
Nothing -> Nothing
|
||||
Just v -> Just (Term.var (ABT.annotation t) v)
|
||||
go _ = Nothing
|
||||
unref rv t = ABT.visitPure go t
|
||||
where
|
||||
go t@(Term.Ref' r@(Reference.DerivedId _)) = case Map.lookup r rv of
|
||||
Nothing -> Nothing
|
||||
Just v -> Just (Term.var (ABT.annotation t) v)
|
||||
go _ = Nothing
|
||||
|
||||
@ -153,11 +153,24 @@ notifyUser dir o = case o of
|
||||
intercalateMap "\n\n" (renderNoteAsANSI ppenv (Text.unpack src))
|
||||
. map Result.TypeError
|
||||
putStrLn . showNote $ notes
|
||||
Evaluated fileContents ppe watches ->
|
||||
Evaluated fileContents ppe bindings watches ->
|
||||
if null watches then putStrLn ""
|
||||
else putPrettyLn $ P.lines
|
||||
[ watchPrinter fileContents ppe ann evald isCacheHit
|
||||
| (_v, (ann,evald,isCacheHit)) <- Map.toList watches ]
|
||||
else
|
||||
-- todo: hashqualify binding names if necessary to distinguish them from
|
||||
-- defs in the codebase. In some cases it's fine for bindings to
|
||||
-- shadow codebase names, but you don't want it to capture them in
|
||||
-- the decompiled output.
|
||||
let prettyBindings = P.map fromString . P.bracket . P.lines $
|
||||
P.wrap "The watch expression(s) reference these definitions:" : "" :
|
||||
[TermPrinter.prettyBinding ppe (HQ.fromVar v) b
|
||||
| (v, b) <- bindings]
|
||||
prettyWatches = P.lines [
|
||||
watchPrinter fileContents ppe ann evald isCacheHit |
|
||||
(_v, (ann,evald,isCacheHit)) <- Map.toList watches ]
|
||||
-- todo: use P.nonempty
|
||||
in putPrettyLn $ if null bindings then prettyWatches
|
||||
else prettyBindings <> "\n" <> prettyWatches
|
||||
|
||||
DisplayConflicts branch -> do
|
||||
showConflicts "terms" terms
|
||||
showConflicts "types" types
|
||||
@ -291,15 +304,15 @@ displayDefinitions outputLoc ppe terms types =
|
||||
<> P.newline
|
||||
<> tip "You might need to repair the codebase manually."
|
||||
|
||||
unsafePrettyTermResult' :: Var v =>
|
||||
unsafePrettyTermResultSig' :: Var v =>
|
||||
PPE.PrettyPrintEnv -> E.TermResult' v a -> P.Pretty P.ColorText
|
||||
unsafePrettyTermResult' ppe = \case
|
||||
E.TermResult'' name (Just typ) _r aliases ->
|
||||
unsafePrettyTermResultSig' ppe = \case
|
||||
E.TermResult'' name (Just typ) _r _aliases ->
|
||||
head (TypePrinter.prettySignatures' ppe [(name,typ)])
|
||||
_ -> error "Don't pass Nothing"
|
||||
|
||||
prettyTypeResult' :: E.TypeResult' v a -> P.Pretty P.ColorText
|
||||
prettyTypeResult' (E.TypeResult'' name dt r aliases) =
|
||||
prettyTypeResultHeader' :: E.TypeResult' v a -> P.Pretty P.ColorText
|
||||
prettyTypeResultHeader' (E.TypeResult'' name dt r _aliases) =
|
||||
prettyDeclTriple (name, r, dt)
|
||||
|
||||
prettyAliases ::
|
||||
@ -412,7 +425,7 @@ listOfDefinitions branch results = do
|
||||
where
|
||||
ppe = Branch.prettyPrintEnv branch
|
||||
prettyResults =
|
||||
map (E.searchResult' (unsafePrettyTermResult' ppe) prettyTypeResult')
|
||||
map (E.searchResult' (unsafePrettyTermResultSig' ppe) prettyTypeResultHeader')
|
||||
(filter (not . missingType) results)
|
||||
-- typeResults = map prettyDeclTriple types
|
||||
missingType (E.Tm _ Nothing _ _) = True
|
||||
|
||||
@ -4,6 +4,7 @@ module Unison.Pattern where
|
||||
|
||||
import Data.List (intercalate)
|
||||
import Data.Int (Int64)
|
||||
import Data.Text (Text)
|
||||
import Data.Word (Word64)
|
||||
import Data.Foldable as Foldable
|
||||
import GHC.Generics
|
||||
@ -36,6 +37,7 @@ data PatternP loc
|
||||
| IntP loc !Int64
|
||||
| NatP loc !Word64
|
||||
| FloatP loc !Double
|
||||
| TextP loc !Text
|
||||
| ConstructorP loc !Reference !Int [PatternP loc]
|
||||
| AsP loc (PatternP loc)
|
||||
| EffectPureP loc (PatternP loc)
|
||||
@ -49,6 +51,7 @@ instance Show (PatternP loc) where
|
||||
show (IntP _ x) = "Int " <> show x
|
||||
show (NatP _ x) = "Nat " <> show x
|
||||
show (FloatP _ x) = "Float " <> show x
|
||||
show (TextP _ t) = "Text " <> show t
|
||||
show (ConstructorP _ r i ps) =
|
||||
"Constructor " <> intercalate " " [show r, show i, show ps]
|
||||
show (AsP _ p) = "As " <> show p
|
||||
@ -73,6 +76,7 @@ pattern Boolean b = BooleanP () b
|
||||
pattern Int n = IntP () n
|
||||
pattern Nat n = NatP () n
|
||||
pattern Float n = FloatP () n
|
||||
pattern Text t = TextP () t
|
||||
pattern Constructor r cid ps = ConstructorP () r cid ps
|
||||
pattern As p = AsP () p
|
||||
pattern EffectPure p = EffectPureP () p
|
||||
@ -98,6 +102,7 @@ instance H.Hashable (PatternP p) where
|
||||
tokens (EffectBindP _ r n args k) =
|
||||
[H.Tag 8, H.accumulateToken r, H.Nat $ fromIntegral n, H.accumulateToken args, H.accumulateToken k]
|
||||
tokens (AsP _ p) = H.Tag 9 : H.tokens p
|
||||
tokens (TextP _ t) = H.Tag 10 : H.tokens t
|
||||
|
||||
instance Eq (PatternP loc) where
|
||||
UnboundP _ == UnboundP _ = True
|
||||
@ -110,6 +115,7 @@ instance Eq (PatternP loc) where
|
||||
EffectPureP _ p == EffectPureP _ q = p == q
|
||||
EffectBindP _ r ctor ps k == EffectBindP _ r2 ctor2 ps2 k2 = r == r2 && ctor == ctor2 && ps == ps2 && k == k2
|
||||
AsP _ p == AsP _ q = p == q
|
||||
TextP _ t == TextP _ t2 = t == t2
|
||||
_ == _ = False
|
||||
|
||||
|
||||
|
||||
@ -12,6 +12,7 @@ pattern Boolean loc b = P.BooleanP loc b
|
||||
pattern Int loc n = P.IntP loc n
|
||||
pattern Nat loc n = P.NatP loc n
|
||||
pattern Float loc n = P.FloatP loc n
|
||||
pattern Text loc t = P.TextP loc t
|
||||
pattern Constructor loc r cid ps = P.ConstructorP loc r cid ps
|
||||
pattern As loc p = P.AsP loc p
|
||||
pattern EffectPure loc p = P.EffectPureP loc p
|
||||
|
||||
@ -9,9 +9,12 @@
|
||||
{-# Language TupleSections #-}
|
||||
{-# Language ViewPatterns #-}
|
||||
{-# Language PatternSynonyms #-}
|
||||
{-# Language DoAndIfThenElse #-}
|
||||
|
||||
module Unison.Runtime.IR where
|
||||
|
||||
import Control.Monad.State.Strict (StateT, gets, modify, runStateT, lift)
|
||||
import Data.Bifunctor (first, second)
|
||||
import Debug.Trace
|
||||
import Data.Foldable
|
||||
import Data.Functor (void)
|
||||
@ -69,12 +72,13 @@ toSymbolC :: Symbol -> SymbolC
|
||||
toSymbolC s = SymbolC False s
|
||||
|
||||
-- Values, in normal form
|
||||
type RefID = Int
|
||||
data Value e
|
||||
= I Int64 | F Double | N Word64 | B Bool | T Text
|
||||
| Lam Arity (UnderapplyStrategy e) (IR e)
|
||||
| Data R.Reference ConstructorId [Value e]
|
||||
| Sequence (Vector (Value e))
|
||||
| Ref Int Symbol (IORef (Value e))
|
||||
| Ref RefID Symbol (IORef (Value e))
|
||||
| Pure (Value e)
|
||||
| Requested (Req e)
|
||||
| Cont (IR e)
|
||||
@ -117,15 +121,22 @@ pair (a, b) = Data Type.pairRef 0 [a, b]
|
||||
-- The reason is that builtins and constructor functions don't have a body
|
||||
-- with variables that we could substitute - the functions only compute
|
||||
-- to anything when all the arguments are available.
|
||||
|
||||
data UnderapplyStrategy e
|
||||
= FormClosure (Term SymbolC) [Value e]
|
||||
| Specialize (Term SymbolC) [(SymbolC, Value e)]
|
||||
= FormClosure (Term SymbolC) [Value e] -- head is the latest argument
|
||||
| Specialize (Term SymbolC) [(SymbolC, Value e)] -- same
|
||||
deriving (Eq, Show)
|
||||
|
||||
decompileUnderapplied :: UnderapplyStrategy e -> IO (Term SymbolC)
|
||||
decompileUnderapplied = \case
|
||||
FormClosure _ _ -> error "todo"
|
||||
Specialize _ _ -> error "todo"
|
||||
decompileUnderapplied :: External e => UnderapplyStrategy e -> DS (Term Symbol)
|
||||
decompileUnderapplied u = case u of -- todo: consider unlambda-lifting here
|
||||
FormClosure lam vals ->
|
||||
Term.apps' (Term.vmap underlyingSymbol lam) . reverse <$>
|
||||
traverse decompileImpl vals
|
||||
Specialize lam symvals -> do
|
||||
lam <- Term.apps' (Term.vmap underlyingSymbol lam) . reverse <$>
|
||||
traverse (decompileImpl . snd) symvals
|
||||
pure $ Term.betaReduce lam
|
||||
|
||||
|
||||
-- Patterns - for now this follows Unison.Pattern exactly, but
|
||||
-- we may switch to more efficient runtime representation of patterns
|
||||
@ -185,8 +196,7 @@ data IR' z
|
||||
|
||||
-- Contains the effect ref and ctor id, the args, and the continuation
|
||||
-- which expects the result at the top of the stack
|
||||
data Req e
|
||||
= Req R.Reference ConstructorId [Value e] (IR e)
|
||||
data Req e = Req R.Reference ConstructorId [Value e] (IR e)
|
||||
deriving (Eq,Show)
|
||||
|
||||
-- Appends `k2` to the end of the `k` continuation
|
||||
@ -200,6 +210,39 @@ appendCont v (Req r cid args k) k2 = Req r cid args (Let v k k2)
|
||||
wrapHandler :: Value e -> Req e -> Req e
|
||||
wrapHandler h (Req r cid args k) = Req r cid args (Handle (Val h) k)
|
||||
|
||||
-- Annotate all `z` values with the number of outer bindings, useful for
|
||||
-- tracking free variables or converting away from debruijn indexing.
|
||||
-- Currently used as an implementation detail by `specializeIR`.
|
||||
annotateDepth :: IR' z -> IR' (z, Int)
|
||||
annotateDepth ir = go 0 ir where
|
||||
go depth ir = case ir of
|
||||
-- Only the binders modify the depth
|
||||
Let v b body -> Let v (go depth b) (go (depth + 1) body)
|
||||
LetRec bs body -> let
|
||||
depth' = depth + length bs
|
||||
in LetRec (second (go depth') <$> bs) (go depth' body)
|
||||
Match scrute cases -> Match (scrute, depth) (tweak <$> cases) where
|
||||
tweak (pat, boundVars, guard, rhs) = let
|
||||
depth' = depth + length boundVars
|
||||
in (pat, boundVars, go depth' <$> guard, go depth' rhs)
|
||||
-- All the other cases just leave depth alone and recurse
|
||||
Apply f args -> Apply (go depth f) ((,depth) <$> args)
|
||||
Handle f body -> Handle (f,depth) (go depth body)
|
||||
If c a b -> If (c,depth) (go depth a) (go depth b)
|
||||
And a b -> And (a,depth) (go depth b)
|
||||
Or a b -> Or (a,depth) (go depth b)
|
||||
ir -> (,depth) <$> ir
|
||||
|
||||
-- Given an environment mapping of de bruijn indices to values, specialize
|
||||
-- the given `IR` by replacing slot lookups with the provided values.
|
||||
specializeIR :: Map Int (Value e) -> IR' (Z e) -> IR' (Z e)
|
||||
specializeIR env ir = let
|
||||
ir' = annotateDepth ir
|
||||
go (s@(Slot i), depth) = maybe s Val $ Map.lookup (i - depth) env
|
||||
go (s@(LazySlot i), depth) = maybe s Val $ Map.lookup (i - depth) env
|
||||
go (s,_) = s
|
||||
in go <$> ir'
|
||||
|
||||
compile :: Show e => CompilationEnv e -> Term Symbol -> IR e
|
||||
compile env t = compile0 env [] (Term.vmap toSymbolC t)
|
||||
|
||||
@ -302,28 +345,229 @@ compile0 env bound t =
|
||||
Pattern.Int n -> PatternI n
|
||||
Pattern.Nat n -> PatternN n
|
||||
Pattern.Float n -> PatternF n
|
||||
Pattern.Text t -> PatternT t
|
||||
Pattern.Constructor r cid args -> PatternData r cid (compilePattern <$> args)
|
||||
Pattern.As pat -> PatternAs (compilePattern pat)
|
||||
Pattern.EffectPure p -> PatternPure (compilePattern p)
|
||||
Pattern.EffectBind r cid args k -> PatternBind r cid (compilePattern <$> args) (compilePattern k)
|
||||
_ -> error $ "todo - compilePattern " ++ show pat
|
||||
|
||||
decompile :: Value e -> IO (Term SymbolC)
|
||||
decompile v = case v of
|
||||
type DS = StateT (Map Symbol (Term Symbol), Set RefID) IO
|
||||
|
||||
decompile :: External e => Value e -> IO (Term Symbol)
|
||||
decompile v = do
|
||||
(body, (letRecBindings, _)) <- runStateT (decompileImpl v) mempty
|
||||
pure $ if null letRecBindings then body
|
||||
else Term.letRec' False (Map.toList letRecBindings) body
|
||||
|
||||
decompileImpl ::
|
||||
External e => Value e -> DS (Term Symbol)
|
||||
decompileImpl v = case v of
|
||||
I n -> pure $ Term.int () n
|
||||
N n -> pure $ Term.nat () n
|
||||
F n -> pure $ Term.float () n
|
||||
B b -> pure $ Term.boolean () b
|
||||
T t -> pure $ Term.text () t
|
||||
Lam _ f _ -> decompileUnderapplied f
|
||||
Data r cid args -> Term.apps' <$> pure (Term.constructor() r cid) <*> traverse decompile (toList args)
|
||||
Sequence vs -> Term.vector' () <$> traverse decompile vs
|
||||
Ref _ _ _ -> error "IR todo - decompile Ref"
|
||||
Cont _ -> error "Nothing"
|
||||
Pure _ -> error "Nothing"
|
||||
Requested _ -> error "Nothing"
|
||||
Data r cid args ->
|
||||
Term.apps' <$> pure (Term.constructor() r cid)
|
||||
<*> traverse decompileImpl (toList args)
|
||||
Sequence vs -> Term.vector' () <$> traverse decompileImpl vs
|
||||
Ref id symbol ioref -> do
|
||||
seen <- gets snd
|
||||
symbol <- pure $ Var.freshenId (fromIntegral id) symbol
|
||||
if Set.member id seen then
|
||||
pure $ Term.var () symbol
|
||||
else do
|
||||
modify (second $ Set.insert id)
|
||||
t <- decompileImpl =<< lift (readIORef ioref)
|
||||
modify (first $ Map.insert symbol t)
|
||||
pure (Term.etaNormalForm t)
|
||||
Cont k -> Term.lam () contIn <$> decompileIR [contIn] k
|
||||
where contIn = Var.freshIn (boundVarsIR k) (Var.named "result")
|
||||
Pure a -> do
|
||||
-- `{a}` doesn't have a term syntax, so it's decompiled as
|
||||
-- `handle (x -> x) in a`, which has the type `Request ambient e a`
|
||||
a <- decompileImpl a
|
||||
pure $ Term.handle() id a
|
||||
Requested (Req r cid vs k) -> do
|
||||
-- `{req a b -> k}` doesn't have a term syntax, so it's decompiled as
|
||||
-- `handle (x -> x) in k (req a b)`
|
||||
vs <- traverse decompileImpl vs
|
||||
let v = Var.freshIn (boundVarsIR k) (Var.named "result")
|
||||
k <- decompileIR [v] k
|
||||
pure . Term.handle() id $
|
||||
Term.apps' (Term.lam() v k) [Term.apps' (Term.request() r cid) vs]
|
||||
UninitializedLetRecSlot _b _bs _body ->
|
||||
error "unpossible - decompile UninitializedLetRecSlot"
|
||||
where
|
||||
idv = Var.named "x"
|
||||
id = Term.lam () idv (Term.var() idv)
|
||||
|
||||
|
||||
boundVarsIR :: IR e -> Set Symbol
|
||||
boundVarsIR = \case
|
||||
Let v b body -> Set.singleton v <> boundVarsIR b <> boundVarsIR body
|
||||
LetRec bs body -> Set.fromList (fst <$> bs) <> foldMap (boundVarsIR . snd) bs <> boundVarsIR body
|
||||
Apply lam _ -> boundVarsIR lam
|
||||
Handle _ body -> boundVarsIR body
|
||||
If _ t f -> foldMap boundVarsIR [t,f]
|
||||
And _ b -> boundVarsIR b
|
||||
Or _ b -> boundVarsIR b
|
||||
Match _ cases -> foldMap doCase cases
|
||||
where doCase (_, _, b, body) = maybe mempty boundVarsIR b <> boundVarsIR body
|
||||
-- I added all these cases for exhaustiveness checking in the future,
|
||||
-- and also because I needed the patterns for decompileIR anyway.
|
||||
-- Sure is ugly though. This ghc doesn't support Language MultiCase.
|
||||
-- I want to be able to say `_ -> mempty` where _ refers to exactly the other
|
||||
-- cases that existed at the time I wrote it!
|
||||
Leaf _ -> mempty
|
||||
AddI _ _ -> mempty
|
||||
SubI _ _ -> mempty
|
||||
MultI _ _ -> mempty
|
||||
DivI _ _ -> mempty
|
||||
GtI _ _ -> mempty
|
||||
LtI _ _ -> mempty
|
||||
GtEqI _ _ -> mempty
|
||||
LtEqI _ _ -> mempty
|
||||
EqI _ _ -> mempty
|
||||
SignumI _ -> mempty
|
||||
NegateI _ -> mempty
|
||||
ModI _ _ -> mempty
|
||||
AddN _ _ -> mempty
|
||||
DropN _ _ -> mempty
|
||||
SubN _ _ -> mempty
|
||||
MultN _ _ -> mempty
|
||||
DivN _ _ -> mempty
|
||||
GtN _ _ -> mempty
|
||||
LtN _ _ -> mempty
|
||||
GtEqN _ _ -> mempty
|
||||
LtEqN _ _ -> mempty
|
||||
EqN _ _ -> mempty
|
||||
ModN _ _ -> mempty
|
||||
AddF _ _ -> mempty
|
||||
SubF _ _ -> mempty
|
||||
MultF _ _ -> mempty
|
||||
DivF _ _ -> mempty
|
||||
GtF _ _ -> mempty
|
||||
LtF _ _ -> mempty
|
||||
GtEqF _ _ -> mempty
|
||||
LtEqF _ _ -> mempty
|
||||
EqF _ _ -> mempty
|
||||
MakeSequence _ -> mempty
|
||||
Construct _ _ _ -> mempty
|
||||
Request _ _ _ -> mempty
|
||||
Not _ -> mempty
|
||||
|
||||
class External e where
|
||||
decompileExternal :: e -> Term Symbol
|
||||
|
||||
decompileIR :: External e => [Symbol] -> IR e -> DS (Term Symbol)
|
||||
decompileIR stack = \case
|
||||
-- added all these cases for exhaustiveness checking in the future,
|
||||
-- and also because I needed the patterns for decompileIR anyway.
|
||||
Leaf z -> decompileZ z
|
||||
AddI x y -> builtin "Int.+" [x,y]
|
||||
SubI x y -> builtin "Int.-" [x,y]
|
||||
MultI x y -> builtin "Int.*" [x,y]
|
||||
DivI x y -> builtin "Int./" [x,y]
|
||||
GtI x y -> builtin "Int.>" [x,y]
|
||||
LtI x y -> builtin "Int.<" [x,y]
|
||||
GtEqI x y -> builtin "Int.>=" [x,y]
|
||||
LtEqI x y -> builtin "Int.<=" [x,y]
|
||||
EqI x y -> builtin "Int.==" [x,y]
|
||||
SignumI x -> builtin "Int.signum" [x]
|
||||
NegateI x -> builtin "Int.negate" [x]
|
||||
ModI x y -> builtin "Int.mod" [x,y]
|
||||
AddN x y -> builtin "Nat.+" [x,y]
|
||||
DropN x y -> builtin "Nat.drop" [x,y]
|
||||
SubN x y -> builtin "Nat.sub" [x,y]
|
||||
MultN x y -> builtin "Nat.*" [x,y]
|
||||
DivN x y -> builtin "Nat./" [x,y]
|
||||
GtN x y -> builtin "Nat.>" [x,y]
|
||||
LtN x y -> builtin "Nat.<" [x,y]
|
||||
GtEqN x y -> builtin "Nat.>=" [x,y]
|
||||
LtEqN x y -> builtin "Nat.<=" [x,y]
|
||||
EqN x y -> builtin "Nat.==" [x,y]
|
||||
ModN x y -> builtin "Nat.mod" [x,y]
|
||||
AddF x y -> builtin "Float.+" [x,y]
|
||||
SubF x y -> builtin "Float.-" [x,y]
|
||||
MultF x y -> builtin "Float.*" [x,y]
|
||||
DivF x y -> builtin "Float./" [x,y]
|
||||
GtF x y -> builtin "Float.>" [x,y]
|
||||
LtF x y -> builtin "Float.<" [x,y]
|
||||
GtEqF x y -> builtin "Float.>=" [x,y]
|
||||
LtEqF x y -> builtin "Float.<=" [x,y]
|
||||
EqF x y -> builtin "Float.==" [x,y]
|
||||
Let v b body -> do
|
||||
b' <- decompileIR stack b
|
||||
body' <- decompileIR (v:stack) body
|
||||
pure $ Term.let1_ False [(v, b')] body'
|
||||
LetRec bs body -> do
|
||||
let stack' = reverse (fmap fst bs) ++ stack
|
||||
secondM f (x,y) = (x,) <$> f y
|
||||
bs' <- traverse (secondM $ decompileIR stack') bs
|
||||
body' <- decompileIR stack' body
|
||||
pure $ Term.letRec' False bs' body'
|
||||
MakeSequence args ->
|
||||
Term.vector() <$> traverse decompileZ args
|
||||
Apply lam args ->
|
||||
Term.apps' <$> decompileIR stack lam <*> traverse decompileZ args
|
||||
Construct r cid args ->
|
||||
Term.apps' (Term.constructor() r cid) <$> traverse decompileZ args
|
||||
Request r cid args ->
|
||||
Term.apps' (Term.request() r cid) <$> traverse decompileZ args
|
||||
Handle h body ->
|
||||
Term.handle() <$> decompileZ h <*> decompileIR stack body
|
||||
If c t f ->
|
||||
Term.iff() <$> decompileZ c <*> decompileIR stack t <*> decompileIR stack f
|
||||
And x y ->
|
||||
Term.and() <$> decompileZ x <*> decompileIR stack y
|
||||
Or x y ->
|
||||
Term.or() <$> decompileZ x <*> decompileIR stack y
|
||||
Not x -> builtin "Boolean.not" [x]
|
||||
Match scrutinee cases ->
|
||||
Term.match () <$> decompileZ scrutinee <*> traverse decompileMatchCase cases
|
||||
where
|
||||
builtin :: External e => Text -> [Z e] -> DS (Term Symbol)
|
||||
builtin t args =
|
||||
Term.apps' (Term.ref() (R.Builtin t)) <$> traverse decompileZ args
|
||||
at :: Pos -> Term Symbol
|
||||
at i = Term.var() (stack !! i)
|
||||
decompileZ :: External e => Z e -> DS (Term Symbol)
|
||||
decompileZ = \case
|
||||
Slot p -> pure $ at p
|
||||
LazySlot p -> pure $ at p
|
||||
Val v -> decompileImpl v
|
||||
External e -> pure $ decompileExternal e
|
||||
decompilePattern :: Pattern -> Pattern.Pattern
|
||||
decompilePattern = \case
|
||||
PatternI i -> Pattern.Int i
|
||||
PatternN n -> Pattern.Nat n
|
||||
PatternF f -> Pattern.Float f
|
||||
PatternB b -> Pattern.Boolean b
|
||||
PatternT t -> Pattern.Text t
|
||||
PatternData r cid pats ->
|
||||
Pattern.Constructor r cid (d <$> pats)
|
||||
PatternSequence v -> error "todo" v
|
||||
-- case vec of
|
||||
-- head +: tail -> ...
|
||||
-- init :+ last -> ...
|
||||
-- [] -> ...
|
||||
-- [1,2,3] -> ...
|
||||
-- [1,2,3] ++ mid ++ [7,8,9] -> ... maybe?
|
||||
PatternPure pat -> Pattern.EffectPure (d pat)
|
||||
PatternBind r cid pats k ->
|
||||
Pattern.EffectBind r cid (d <$> pats) (d k)
|
||||
PatternAs pat -> Pattern.As (d pat)
|
||||
PatternIgnore -> Pattern.Unbound
|
||||
PatternVar -> Pattern.Var
|
||||
d = decompilePattern
|
||||
decompileMatchCase (pat, vars, guard, body) = do
|
||||
let stack' = reverse vars ++ stack
|
||||
guard' <- traverse (decompileIR stack') guard
|
||||
body' <- decompileIR stack' body
|
||||
pure $ Term.MatchCase (d pat) guard' body'
|
||||
|
||||
instance Show e => Show (Z e) where
|
||||
show (LazySlot i) = "'#" ++ show i
|
||||
|
||||
@ -3,17 +3,18 @@
|
||||
{-# Language OverloadedStrings #-}
|
||||
{-# Language Strict #-}
|
||||
{-# Language StrictData #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# Language RankNTypes #-}
|
||||
{-# Language TupleSections #-}
|
||||
{-# Language PatternSynonyms #-}
|
||||
{-# Language ViewPatterns #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# Language ScopedTypeVariables #-}
|
||||
{-# Language DoAndIfThenElse #-}
|
||||
|
||||
|
||||
module Unison.Runtime.Rt1 where
|
||||
|
||||
import Data.Bifunctor (second)
|
||||
import Control.Monad (foldM, join)
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import Data.Foldable (for_, toList)
|
||||
import Data.IORef
|
||||
import Data.Int (Int64)
|
||||
@ -22,11 +23,9 @@ import Data.Text (Text)
|
||||
import Data.Traversable (for)
|
||||
import Data.Word (Word64)
|
||||
import Data.Vector (Vector)
|
||||
import Unison.Codebase.Runtime (Runtime(Runtime))
|
||||
import Unison.Runtime.IR (pattern CompilationEnv, pattern Req)
|
||||
import Unison.Runtime.IR hiding (CompilationEnv, IR, Req, Value, Z)
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.TermPrinter (prettyTop)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Vector as Vector
|
||||
@ -36,7 +35,6 @@ import qualified Unison.DataDeclaration as DD
|
||||
import qualified Unison.Reference as R
|
||||
import qualified Unison.Runtime.IR as IR
|
||||
import qualified Unison.Term as Term
|
||||
import qualified Unison.Util.Pretty as Pretty
|
||||
import qualified Unison.Var as Var
|
||||
import Debug.Trace
|
||||
|
||||
@ -46,26 +44,13 @@ type Req = IR.Req ExternalFunction
|
||||
type Value = IR.Value ExternalFunction
|
||||
type Z = IR.Z ExternalFunction
|
||||
|
||||
newtype ExternalFunction = ExternalFunction (Size -> Stack -> IO Value)
|
||||
data ExternalFunction =
|
||||
ExternalFunction R.Reference (Size -> Stack -> IO Value)
|
||||
instance External ExternalFunction where
|
||||
decompileExternal (ExternalFunction r _) = Term.ref () r
|
||||
|
||||
type Stack = MV.IOVector Value
|
||||
|
||||
runtime :: Runtime Symbol
|
||||
runtime = Runtime terminate eval
|
||||
where
|
||||
terminate :: forall m. MonadIO m => m ()
|
||||
terminate = pure ()
|
||||
changeVar term = Term.vmap IR.underlyingSymbol term
|
||||
eval :: (MonadIO m, Monoid a) => CL.CodeLookup m Symbol a -> Term.AnnotatedTerm Symbol a -> m (Term Symbol)
|
||||
eval cl term = do
|
||||
liftIO . putStrLn $ Pretty.render 80 (prettyTop mempty term)
|
||||
cenv <- compilationEnv cl term -- in `m`
|
||||
RDone result <- liftIO $
|
||||
run cenv (compile cenv $ Term.amap (const ()) term)
|
||||
decompiled <- liftIO $ decompile result
|
||||
pure . changeVar $ decompiled
|
||||
|
||||
|
||||
-- compile :: Show e => CompilationEnv e -> Term Symbol -> IR e
|
||||
-- compilationEnv :: Monad m
|
||||
-- => CL.CodeLookup m Symbol a
|
||||
@ -84,7 +69,7 @@ at size i m = case i of
|
||||
force =<< MV.read m (size - i - 1)
|
||||
LazySlot i ->
|
||||
MV.read m (size - i - 1)
|
||||
External (ExternalFunction e) -> e size m
|
||||
External (ExternalFunction _ e) -> e size m
|
||||
|
||||
ati :: Size -> Z -> Stack -> IO Int64
|
||||
ati size i m = at size i m >>= \case
|
||||
@ -116,6 +101,11 @@ ats size i m = at size i m >>= \case
|
||||
Sequence v -> pure v
|
||||
_ -> fail "type error, expecting Sequence"
|
||||
|
||||
atd :: Size -> Z -> Stack -> IO (R.Reference, ConstructorId, [Value])
|
||||
atd size i m = at size i m >>= \case
|
||||
Data r id vs -> pure (r, id, vs)
|
||||
_ -> fail "type error, expecting Data"
|
||||
|
||||
push :: Size -> Value -> Stack -> IO Stack
|
||||
push size v s0 = do
|
||||
s1 <-
|
||||
@ -254,7 +244,7 @@ builtinCompilationEnv = CompilationEnv (builtinsMap <> IR.builtins) mempty
|
||||
. Lam arity (underapply name)
|
||||
. Leaf
|
||||
. External
|
||||
. ExternalFunction
|
||||
. ExternalFunction (R.Builtin name)
|
||||
underapply name = FormClosure (Term.ref () $ R.Builtin name) []
|
||||
mk1
|
||||
:: Text
|
||||
@ -285,8 +275,11 @@ builtinCompilationEnv = CompilationEnv (builtinsMap <> IR.builtins) mempty
|
||||
mkC $ f a b
|
||||
)
|
||||
|
||||
run :: CompilationEnv -> IR -> IO Result
|
||||
run env ir = do
|
||||
run :: (R.Reference -> ConstructorId -> [Value] -> IO Value)
|
||||
-> CompilationEnv
|
||||
-> IR
|
||||
-> IO Result
|
||||
run ioHandler env ir = do
|
||||
supply <- newIORef 0
|
||||
m0 <- MV.new 256
|
||||
MV.set m0 (T "uninitialized")
|
||||
@ -294,6 +287,8 @@ run env ir = do
|
||||
fresh :: IO Int
|
||||
fresh = atomicModifyIORef' supply (\n -> (n + 1, n))
|
||||
|
||||
-- TODO:
|
||||
-- go :: (MonadReader Size m, MonadState Stack m, MonadIO m) => IR -> m Result
|
||||
go :: Size -> Stack -> IR -> IO Result
|
||||
go size m ir = do
|
||||
stackStuff <- traverse (MV.read m) [0..size-1]
|
||||
@ -333,45 +328,13 @@ run env ir = do
|
||||
runHandler size m h body
|
||||
Apply fn args -> do
|
||||
RDone fn <- go size m fn -- ANF should ensure this match is OK
|
||||
fn <- force fn
|
||||
call size m fn args
|
||||
Match scrutinee cases -> do
|
||||
-- scrutinee : Z -- already evaluated :amazing:
|
||||
-- cases : [(Pattern, Maybe IR, IR)]
|
||||
scrute <- at size scrutinee m -- "I am scrute" / "Dwight K. Scrute"
|
||||
let
|
||||
getCapturedVars :: (Value, Pattern) -> Maybe [Value]
|
||||
getCapturedVars = \case
|
||||
(I x, PatternI x2) | x == x2 -> Just []
|
||||
(F x, PatternF x2) | x == x2 -> Just []
|
||||
(N x, PatternN x2) | x == x2 -> Just []
|
||||
(B x, PatternB x2) | x == x2 -> Just []
|
||||
(T x, PatternT x2) | x == x2 -> Just []
|
||||
(Data r cid args, PatternData r2 cid2 pats)
|
||||
| r == r2 && cid == cid2 ->
|
||||
join <$> traverse getCapturedVars (zip args pats)
|
||||
(Sequence args, PatternSequence pats) ->
|
||||
join <$> traverse getCapturedVars (zip (toList args) (toList pats))
|
||||
(Pure v, PatternPure p) -> getCapturedVars (v, p)
|
||||
(Requested (Req r cid args k), PatternBind r2 cid2 pats kpat)
|
||||
| r == r2 && cid == cid2 ->
|
||||
join <$> traverse getCapturedVars (zip (args ++ [Cont k]) (pats ++ [kpat]))
|
||||
(v, PatternAs p) -> (v:) <$> getCapturedVars (v,p)
|
||||
(_, PatternIgnore) -> Just []
|
||||
(v, PatternVar) -> Just [v]
|
||||
(v, p) -> error $
|
||||
"unpossible: getCapturedVars (" <> show v <> ", " <> show p <> ")"
|
||||
tryCases m ((pat, _vars, cond, body) : remainingCases) =
|
||||
case getCapturedVars (scrute, pat) of
|
||||
Nothing -> tryCases m remainingCases -- this pattern didn't match
|
||||
Just vars -> do
|
||||
(size, m) <- pushMany size vars m
|
||||
case cond of
|
||||
Just cond -> do
|
||||
(RDone (B cond)) <- go size m cond
|
||||
if cond then go size m body else tryCases m remainingCases
|
||||
Nothing -> go size m body
|
||||
tryCases _ _ = pure RMatchFail
|
||||
tryCases m cases
|
||||
tryCases size scrute m cases
|
||||
|
||||
-- Builtins
|
||||
AddI i j -> do x <- ati size i m; y <- ati size j m; done (I (x + y))
|
||||
@ -443,32 +406,81 @@ run env ir = do
|
||||
-- foo : Int ->{IO} (Int -> Int)
|
||||
-- ...
|
||||
-- (foo 12 12)
|
||||
RRequest req ->
|
||||
let overApplyName = Var.named "oa" in
|
||||
pure . RRequest . appendCont overApplyName req $ error "todo"
|
||||
RRequest req -> do
|
||||
let overApplyName = Var.named "oa"
|
||||
extraArgvs <- for extraArgs $ \arg -> at size arg m
|
||||
pure . RRequest . appendCont overApplyName req $
|
||||
Apply (Leaf (Slot 0)) (Val <$> extraArgvs)
|
||||
e -> error $ "type error, tried to apply: " <> show e
|
||||
-- underapplied call, e.g. `(x y -> ..) 9`
|
||||
else do
|
||||
argvs <- for args $ \arg -> at size arg m
|
||||
case underapply of
|
||||
-- previousArgs = [mostRecentlyApplied, ..., firstApplied]
|
||||
Specialize lam@(Term.LamsNamed' vs body) previousArgs -> do
|
||||
let
|
||||
nowArgs = reverse (vs `zip` argvs) ++ previousArgs
|
||||
nowArgs' = (second Just <$> nowArgs)
|
||||
vsRemaining = drop (length nowArgs) vs
|
||||
vsRemaining' = (,Nothing) <$> vsRemaining
|
||||
-- todo: is this right??
|
||||
compiled = compile0 env (reverse vsRemaining' ++ nowArgs') body
|
||||
done $ Lam (arity - nargs) (Specialize lam nowArgs) compiled
|
||||
Specialize e previousArgs -> error $ "can't underapply a non-lambda: " <> show e <> " " <> show previousArgs
|
||||
FormClosure tm previousArgs ->
|
||||
done $ Lam (arity - nargs)
|
||||
(FormClosure tm (reverse argvs ++ previousArgs))
|
||||
(error "todo - gotta form an IR that calls the original body with args in the correct order")
|
||||
-- Example 1:
|
||||
-- f = x y z p -> x - y - z - p
|
||||
-- f' = f 1 2 -- Specialize f [2, 1] -- each arg is pushed onto top
|
||||
-- f'' = f' 3 -- Specialize f [3, 2, 1]
|
||||
-- f'' 4 -- should be the same thing as `f 1 2 3 4`
|
||||
--
|
||||
-- pushedArgs = [mostRecentlyApplied, ..., firstApplied]
|
||||
Specialize lam@(Term.LamsNamed' vs body) pushedArgs -> let
|
||||
pushedArgs' :: [ (SymbolC, Value)] -- head is the latest argument
|
||||
pushedArgs' = reverse (drop (length pushedArgs) vs `zip` argvs) ++ pushedArgs
|
||||
vsRemaining = drop (length pushedArgs') vs
|
||||
compiled = compile0 env
|
||||
(reverse (fmap (,Nothing) vsRemaining) ++
|
||||
fmap (second Just) pushedArgs')
|
||||
body
|
||||
in done $ Lam (arity - nargs) (Specialize lam pushedArgs') compiled
|
||||
Specialize e pushedArgs -> error $ "can't underapply a non-lambda: " <> show e <> " " <> show pushedArgs
|
||||
FormClosure tm pushedArgs -> let
|
||||
pushedArgs' = reverse argvs ++ pushedArgs
|
||||
arity' = arity - nargs
|
||||
allArgs = replicate arity' Nothing ++ map Just pushedArgs'
|
||||
bound = Map.fromList [ (i, v) | (Just v, i) <- allArgs `zip` [0..]]
|
||||
in done $ Lam (arity - nargs)
|
||||
(FormClosure tm pushedArgs')
|
||||
(specializeIR bound body)
|
||||
call _ _ fn args =
|
||||
error $ "type error - tried to apply a non-function: " <> show (fn, args)
|
||||
|
||||
-- Just = match success, Nothing = match fail
|
||||
tryCase :: (Value, Pattern) -> Maybe [Value]
|
||||
tryCase = \case
|
||||
(I x, PatternI x2) -> when' (x == x2) $ Just []
|
||||
(F x, PatternF x2) -> when' (x == x2) $ Just []
|
||||
(N x, PatternN x2) -> when' (x == x2) $ Just []
|
||||
(B x, PatternB x2) -> when' (x == x2) $ Just []
|
||||
(T x, PatternT x2) -> when' (x == x2) $ Just []
|
||||
(Data r cid args, PatternData r2 cid2 pats)
|
||||
-> when' (r == r2 && cid == cid2) $
|
||||
join <$> traverse tryCase (zip args pats)
|
||||
(Sequence args, PatternSequence pats) ->
|
||||
join <$> traverse tryCase (zip (toList args) (toList pats))
|
||||
(Pure v, PatternPure p) -> tryCase (v, p)
|
||||
(Requested (Req r cid args k), PatternBind r2 cid2 pats kpat) ->
|
||||
when' (r == r2 && cid == cid2) $
|
||||
join <$> traverse tryCase (zip (args ++ [Cont k]) (pats ++ [kpat]))
|
||||
(v, PatternAs p) -> (v:) <$> tryCase (v,p)
|
||||
(_, PatternIgnore) -> Just []
|
||||
(v, PatternVar) -> Just [v]
|
||||
(v, p) -> error $
|
||||
"unpossible: tryCase (" <> show v <> ", " <> show p <> ")"
|
||||
where when' b m = if b then m else Nothing
|
||||
|
||||
tryCases size scrute m ((pat, _vars, cond, body) : remainingCases) =
|
||||
case tryCase (scrute, pat) of
|
||||
Nothing -> tryCases size scrute m remainingCases -- this pattern didn't match
|
||||
Just vars -> do
|
||||
(size, m) <- pushMany size vars m
|
||||
case cond of
|
||||
Just cond -> do
|
||||
RDone (B cond) <- go size m cond
|
||||
if cond then go size m body
|
||||
else tryCases size scrute m remainingCases
|
||||
Nothing -> go size m body
|
||||
tryCases _ _ _ _ = pure RMatchFail
|
||||
|
||||
-- To evaluate a `let rec`, we push an empty `Ref` onto the stack for each
|
||||
-- binding, then evaluate each binding and set that `Ref` to its result.
|
||||
-- As long as the variable references occur within a function body,
|
||||
@ -488,7 +500,13 @@ run env ir = do
|
||||
writeIORef r result
|
||||
go size' m body
|
||||
|
||||
go 0 m0 ir
|
||||
r <- go 0 m0 ir
|
||||
case r of
|
||||
RRequest (Req ref cid vs k) -> do
|
||||
ioResult <- ioHandler ref cid vs
|
||||
s <- push 0 ioResult m0
|
||||
go 1 s k
|
||||
a -> pure a
|
||||
|
||||
instance Show ExternalFunction where
|
||||
show _ = "ExternalFunction"
|
||||
|
||||
156
parser-typechecker/src/Unison/Runtime/Rt1IO.hs
Normal file
156
parser-typechecker/src/Unison/Runtime/Rt1IO.hs
Normal file
@ -0,0 +1,156 @@
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Unison.Runtime.Rt1IO where
|
||||
|
||||
import Control.Lens
|
||||
import Control.Concurrent.MVar ( MVar
|
||||
, modifyMVar_
|
||||
, readMVar
|
||||
, newMVar
|
||||
)
|
||||
import Control.Monad.Trans ( lift )
|
||||
import Control.Monad.IO.Class ( liftIO )
|
||||
import Control.Monad.Reader ( ReaderT
|
||||
, runReaderT
|
||||
)
|
||||
import Data.GUID ( genText )
|
||||
import Data.List ( genericIndex )
|
||||
import Data.Map ( Map )
|
||||
import qualified Data.Map as Map
|
||||
import Data.Text ( Text )
|
||||
import Data.Text as Text
|
||||
import System.IO ( Handle
|
||||
, IOMode(..)
|
||||
, openFile
|
||||
, hClose
|
||||
)
|
||||
import Unison.Symbol
|
||||
import qualified Unison.Reference as R
|
||||
import qualified Unison.Runtime.Rt1 as RT
|
||||
import qualified Unison.Runtime.IR as IR
|
||||
import qualified Unison.Term as Term
|
||||
import qualified Unison.Codebase.CodeLookup as CL
|
||||
import Unison.DataDeclaration
|
||||
import qualified Unison.Var as Var
|
||||
import Unison.Var ( Var )
|
||||
import qualified Unison.Hash as Hash
|
||||
import qualified Unison.Util.Pretty as Pretty
|
||||
import Unison.TermPrinter ( prettyTop )
|
||||
import Unison.Codebase.Runtime ( Runtime(Runtime) )
|
||||
|
||||
type GUID = Text
|
||||
type IOState = MVar HandleMap
|
||||
|
||||
type UIO ann a = ReaderT (S ann) IO a
|
||||
type HandleMap = Map GUID Handle
|
||||
|
||||
data S a = S
|
||||
{ _ioState :: IOState
|
||||
, _codeLookup :: CL.CodeLookup IO Symbol a
|
||||
}
|
||||
|
||||
makeLenses 'S
|
||||
|
||||
haskellMode :: Text -> IOMode
|
||||
haskellMode mode = case mode of
|
||||
"IOMode.Read" -> ReadMode
|
||||
"IOMode.Write" -> WriteMode
|
||||
"IOMode.Append" -> AppendMode
|
||||
"IOMode.ReadWrite" -> ReadWriteMode
|
||||
_ -> error . Text.unpack $ "Unknown IO mode " <> mode
|
||||
|
||||
newUnisonHandle :: Handle -> UIO a RT.Value
|
||||
newUnisonHandle h = do
|
||||
t <- liftIO $ genText
|
||||
m <- view ioState
|
||||
liftIO . modifyMVar_ m $ pure . Map.insert t h
|
||||
pure $ IR.T t
|
||||
|
||||
deleteUnisonHandle :: Text -> UIO a ()
|
||||
deleteUnisonHandle h = do
|
||||
m <- view ioState
|
||||
liftIO . modifyMVar_ m $ pure . Map.delete h
|
||||
|
||||
getHaskellHandle :: Text -> UIO a (Maybe Handle)
|
||||
getHaskellHandle h = do
|
||||
m <- view ioState
|
||||
v <- liftIO $ readMVar m
|
||||
pure $ Map.lookup h v
|
||||
|
||||
constructorName :: R.Id -> IR.ConstructorId -> UIO a Text
|
||||
constructorName hash cid = do
|
||||
cl <- view codeLookup
|
||||
lift $ constructorName' cl hash cid
|
||||
|
||||
constructorName'
|
||||
:: (Var v, Monad m)
|
||||
=> CL.CodeLookup m v a
|
||||
-> R.Id
|
||||
-> IR.ConstructorId
|
||||
-> m Text
|
||||
constructorName' cl hash cid = do
|
||||
mayDecl <- CL.getTypeDeclaration cl hash
|
||||
case mayDecl of
|
||||
Nothing -> fail $ "Unknown type: " <> show hash <> " " <> show cid
|
||||
Just (Left (EffectDeclaration dd)) -> go dd
|
||||
Just (Right dd) -> go dd
|
||||
where
|
||||
go (DataDeclaration _ _ ctors) =
|
||||
pure . Var.name $ view _2 $ genericIndex ctors cid
|
||||
|
||||
-- TODO: Put the actual hashes of these types in here
|
||||
ioHash :: R.Id
|
||||
ioHash = R.Id
|
||||
(Hash.unsafeFromBase58
|
||||
"3aEd7hZ5DUwcKcTij4Ba8fUzs6B85euZ9Zcs2iNHxyG9UyDYUzXqgENLo9HNzqRKgXBg7B1eA2nNB1sxMcbqCa15"
|
||||
)
|
||||
0
|
||||
1
|
||||
|
||||
ioModeHash :: R.Id
|
||||
ioModeHash = R.Id (Hash.unsafeFromBase58 "abracadabra1") 0 1
|
||||
|
||||
handleIO' :: S a -> R.Reference -> IR.ConstructorId -> [RT.Value] -> IO RT.Value
|
||||
handleIO' s rid cid vs = case rid of
|
||||
R.DerivedId x | x == ioHash -> runReaderT (handleIO cid vs) s
|
||||
_ -> fail $ "This ability is not an I/O ability: " <> show rid
|
||||
|
||||
handleIO :: IR.ConstructorId -> [RT.Value] -> UIO a RT.Value
|
||||
handleIO cid = (constructorName ioHash cid >>=) . flip go
|
||||
where
|
||||
go "IO.openFile" [IR.T filePath, IR.Data _ mode _] = do
|
||||
n <- constructorName ioModeHash mode
|
||||
h <- liftIO . openFile (Text.unpack filePath) $ haskellMode n
|
||||
newUnisonHandle h
|
||||
go "IO.closeFile" [IR.T handle] = do
|
||||
hh <- getHaskellHandle handle
|
||||
liftIO $ maybe (pure ()) hClose hh
|
||||
deleteUnisonHandle handle
|
||||
pure IR.unit
|
||||
go "IO.printLine" [IR.T string] = do
|
||||
liftIO . putStrLn $ Text.unpack string
|
||||
pure IR.unit
|
||||
go _ _ = undefined
|
||||
|
||||
runtime :: Runtime Symbol
|
||||
runtime = Runtime terminate eval
|
||||
where
|
||||
terminate :: IO ()
|
||||
terminate = pure ()
|
||||
eval
|
||||
:: (Monoid a)
|
||||
=> CL.CodeLookup IO Symbol a
|
||||
-> Term.AnnotatedTerm Symbol a
|
||||
-> IO (Term.Term Symbol)
|
||||
eval cl term = do
|
||||
putStrLn $ Pretty.render 80 (prettyTop mempty term)
|
||||
cenv <- RT.compilationEnv cl term -- in `m`
|
||||
mmap <- newMVar mempty
|
||||
RT.RDone result <- RT.run (handleIO' $ S mmap cl)
|
||||
cenv
|
||||
(IR.compile cenv $ Term.amap (const ()) term)
|
||||
decompiled <- IR.decompile result
|
||||
pure decompiled
|
||||
@ -674,6 +674,15 @@ betaReduce :: Var v => Term v -> Term v
|
||||
betaReduce (App' (Lam' f) arg) = ABT.bind f arg
|
||||
betaReduce e = e
|
||||
|
||||
betaNormalForm :: Var v => Term v -> Term v
|
||||
betaNormalForm (App' f a) = betaNormalForm (betaReduce (app() (betaNormalForm f) a))
|
||||
betaNormalForm e = e
|
||||
|
||||
-- x -> f x => f
|
||||
etaNormalForm :: Eq v => Term v -> Term v
|
||||
etaNormalForm (LamNamed' v (App' f (Var' v'))) | v == v' = etaNormalForm f
|
||||
etaNormalForm t = t
|
||||
|
||||
-- This converts `Reference`s it finds that are in the input `Map`
|
||||
-- back to free variables
|
||||
unhashComponent :: Var v
|
||||
|
||||
@ -99,10 +99,11 @@ parsePattern = constructor <|> leaf
|
||||
where
|
||||
leaf = literal <|> varOrAs <|> unbound <|>
|
||||
parenthesizedOrTuplePattern <|> effect
|
||||
literal = (,[]) <$> asum [true, false, number]
|
||||
literal = (,[]) <$> asum [true, false, number, text]
|
||||
true = (\t -> Pattern.Boolean (ann t) True) <$> reserved "true"
|
||||
false = (\t -> Pattern.Boolean (ann t) False) <$> reserved "false"
|
||||
number = number' (tok Pattern.Int) (tok Pattern.Nat) (tok Pattern.Float)
|
||||
text = (\t -> Pattern.Text (ann t) (L.payload t)) <$> string
|
||||
parenthesizedOrTuplePattern :: P v (Pattern Ann, [(Ann, v)])
|
||||
parenthesizedOrTuplePattern = tupleOrParenthesized parsePattern unit pair
|
||||
unit ann = (Pattern.Constructor ann Type.unitRef 0 [], [])
|
||||
|
||||
@ -309,6 +309,7 @@ prettyPattern n p vs patt = case patt of
|
||||
Pattern.Int _ i -> ((if i >= 0 then l "+" else mempty) <> (l $ show i), vs)
|
||||
Pattern.Nat _ u -> (l $ show u, vs)
|
||||
Pattern.Float _ f -> (l $ show f, vs)
|
||||
Pattern.Text _ t -> (l $ show t, vs)
|
||||
Pattern.Tuple [pp] ->
|
||||
let (printed, tail_vs) = prettyPattern n 10 vs pp
|
||||
in ( paren (p >= 10) $ PP.sep " " ["Pair", printed, "()"]
|
||||
|
||||
@ -886,6 +886,8 @@ checkPattern scrutineeType0 p =
|
||||
lift $ subtype (Type.nat loc) scrutineeType $> mempty
|
||||
Pattern.Float loc _ ->
|
||||
lift $ subtype (Type.float loc) scrutineeType $> mempty
|
||||
Pattern.Text loc _ ->
|
||||
lift $ subtype (Type.text loc) scrutineeType $> mempty
|
||||
Pattern.Constructor loc ref cid args -> do
|
||||
dct <- lift $ getDataConstructorType ref cid
|
||||
udct <- lift $ ungeneralize dct
|
||||
@ -1574,4 +1576,3 @@ instance MonadReader (MEnv v loc) (M v loc) where
|
||||
instance Alternative (M v loc) where
|
||||
empty = liftResult empty
|
||||
a <|> b = a `orElse` b
|
||||
|
||||
|
||||
@ -24,8 +24,9 @@ import qualified Unison.PrettyPrintEnv as PPE
|
||||
import qualified Unison.PrintError as PrintError
|
||||
import Unison.Result (pattern Result, Result)
|
||||
import qualified Unison.Result as Result
|
||||
import qualified Unison.Runtime.Rt1 as RT
|
||||
import qualified Unison.Runtime.Rt1IO as RT
|
||||
import Unison.Symbol (Symbol)
|
||||
import qualified Unison.Term as Term
|
||||
import Unison.Term ( amap )
|
||||
import Unison.Test.Common (parseAndSynthesizeAsFile)
|
||||
import qualified Unison.UnisonFile as UF
|
||||
@ -110,15 +111,17 @@ makePassingTest rt how filepath = scope shortName $ do
|
||||
values <- io $ unpack <$> Data.Text.IO.readFile valueFile
|
||||
let untypedFile = UF.discardTypes file
|
||||
let term = Parsers.parseTerm values $ UF.toNames untypedFile
|
||||
watches <- io $ evaluateWatches Builtin.codeLookup
|
||||
(bindings, watches) <- io $ evaluateWatches Builtin.codeLookup
|
||||
(const $ pure Nothing)
|
||||
rt
|
||||
untypedFile
|
||||
case term of
|
||||
Right tm ->
|
||||
expect $ (view _4 <$> Map.elems watches) == [amap (const ()) tm]
|
||||
Right tm -> let
|
||||
-- compare the the watch expression from the .u with the expr in .ur
|
||||
[watchResult] = view _4 <$> Map.elems watches
|
||||
tm' = Term.letRec' False bindings watchResult
|
||||
in expect $ tm' == amap (const ()) tm
|
||||
Left e -> crash $ show e
|
||||
_ -> pure ()
|
||||
how r
|
||||
where shortName = joinPath . drop 1 . splitPath $ filepath
|
||||
|
||||
|
||||
@ -85,6 +85,7 @@ library
|
||||
Unison.Runtime.ANF
|
||||
Unison.Runtime.IR
|
||||
Unison.Runtime.Rt1
|
||||
Unison.Runtime.Rt1IO
|
||||
Unison.Runtime.Vector
|
||||
Unison.Runtime.SparseVector
|
||||
Unison.Settings
|
||||
@ -131,6 +132,7 @@ library
|
||||
comonad,
|
||||
concurrent-supply,
|
||||
cryptonite,
|
||||
guid,
|
||||
data-memocombinators,
|
||||
directory,
|
||||
errors,
|
||||
|
||||
@ -13,7 +13,7 @@ import qualified Unison.Codebase.Serialization as S
|
||||
import Unison.Codebase.Serialization.V0 (formatSymbol, getSymbol)
|
||||
import qualified Unison.CommandLine.Main as CommandLine
|
||||
import Unison.Parser (Ann (External))
|
||||
import qualified Unison.Runtime.Rt1 as Rt1
|
||||
import qualified Unison.Runtime.Rt1IO as Rt1
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
|
||||
@ -15,6 +15,7 @@ extra-deps:
|
||||
- base58-bytestring-0.1.0
|
||||
- strings-1.1
|
||||
- relation-0.2.1
|
||||
- guid-0.1.0
|
||||
|
||||
ghc-options:
|
||||
# All packages
|
||||
|
||||
@ -3,36 +3,49 @@ type Status = Running | Finished | Canceled | Error Error
|
||||
type Duration = Seconds Nat
|
||||
-- type Abilities e = Abilities {e}
|
||||
|
||||
ability Remote loc where fork : loc {e} -> '{e} a ->{Remote loc} Future loc a
|
||||
ability Remote loc where
|
||||
fork : loc {e}
|
||||
-> '{e} a
|
||||
-> {Remote loc} Future loc a
|
||||
|
||||
forkRegistered : (Future loc a -> {e2} ()) -> loc {e} -> '{e} a
|
||||
-> {Remote loc, e2} Future loc a
|
||||
forkRegistered register loc t =
|
||||
future = Remote.fork loc t
|
||||
register future
|
||||
Future.begin future
|
||||
future
|
||||
|
||||
|
||||
ability Error e where error : e ->{Error e} ()
|
||||
|
||||
|
||||
type Future loc a = Future
|
||||
('{Remote loc, Error Future.Error} a -- join
|
||||
,'{Remote loc} () -- cancel
|
||||
,'{Remote loc} Status -- status
|
||||
,Duration ->{Remote loc} ()) -- keepalive (seconds 10)
|
||||
type Future.Error = Unknown | Unreachable | Unresponsive | AbilityCheckFailure
|
||||
|
||||
Future.join : Future loc a ->{Remote loc, Error Future.Error} a
|
||||
Future.join f = case f of Future.Future (j, c, s, k) -> !j
|
||||
|
||||
Future.cancel : Future loc a ->{Remote loc} ()
|
||||
Future.cancel f = case f of Future.Future (j, c, s, k) -> !c
|
||||
|
||||
Future.status : Future loc a ->{Remote loc} Status
|
||||
Future.status f = case f of Future.Future (j, c, s, k) -> !s
|
||||
|
||||
Future.keepalive : Future loc a -> Duration ->{Remote loc} ()
|
||||
Future.keepalive f d = case f of Future.Future (j, c, s, k) -> k d
|
||||
('{Remote loc} () -- begin
|
||||
,'{Remote loc} () -- cancel
|
||||
,'{Remote loc} Status -- status
|
||||
,'{Remote loc, Error Future.Error} a -- join
|
||||
)
|
||||
type Future.Error = UnknownFuture | UnreachableLocation | UnresponsiveLocation | Terminated | AbilityCheckFailure
|
||||
|
||||
-- Ability.check : Abilities {a} -> Request {b} x -> Boolean
|
||||
-- Ability.check = _
|
||||
|
||||
|
||||
-- Remote.server : (loc {e} -> {e} a) -> {e} a
|
||||
-- Remote.server computation =
|
||||
|
||||
Future.join : Future loc a ->{Remote loc, Error Future.Error} a
|
||||
Future.join f = case f of Future.Future (b, c, s, j) -> !j
|
||||
|
||||
Future.cancel : Future loc a ->{Remote loc} ()
|
||||
Future.cancel f = case f of Future.Future (b, c, s, j) -> !c
|
||||
|
||||
Future.status : Future loc a ->{Remote loc} Status
|
||||
Future.status f = case f of Future.Future (b, c, s, j) -> !s
|
||||
|
||||
Future.begin : Future loc a ->{Remote loc} ()
|
||||
Future.begin f = case f of Future.Future (b, c, s, j) -> !b
|
||||
|
||||
|
||||
type UnitLoc e = UnitLoc
|
||||
|
||||
-- Remote.runSequential : '{Remote UnitLoc, Error e} a -> Either e a
|
||||
|
||||
6
unison-src/tests/text-pattern.u
Normal file
6
unison-src/tests/text-pattern.u
Normal file
@ -0,0 +1,6 @@
|
||||
foo x = case x of
|
||||
"xyz" -> false
|
||||
"abc" -> true
|
||||
_ -> false
|
||||
|
||||
> (foo "abc", foo "xyz", foo "hello, world")
|
||||
1
unison-src/tests/text-pattern.ur
Normal file
1
unison-src/tests/text-pattern.ur
Normal file
@ -0,0 +1 @@
|
||||
(true, false, false)
|
||||
Loading…
Reference in New Issue
Block a user