unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-22 07:48:10 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'trunk' into topic/more-tolerant-gitcache

Browse Source
This commit is contained in:
Arya Irani 2021-06-07 01:59:29 -04:00 committed by GitHub
commit de46c52d7f
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
24 changed files with 495 additions and 195 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
.github/workflows/create-release.yaml vendored Normal file
View File

@ -0,0 +1,28 @@
name: "create-release"
on:
push:
tags:
- "release/*"
jobs:
release:
name: "create-release"
runs-on: "ubuntu-latest"
strategy:
# Run each build to completion, regardless of if any have failed
fail-fast: false
steps:
- name: Checkout
uses: actions/checkout@v2
- name: Create Release
uses: softprops/action-gh-release@v1
env:
GITHUB_TOKEN: "${{ secrets.GITHUB_TOKEN }}"
with:
draft: true

74
.github/workflows/upload-release-artifacts.yaml vendored Normal file
View File

@ -0,0 +1,74 @@
name: "upload-release-artifacts"
on:
workflow_run:
workflows: ["create-release"]
types:
- completed
jobs:
release:
name: ${{ matrix.os }}
runs-on: ${{ matrix.os }}
strategy:
# Run each build to completion, regardless of if any have failed
fail-fast: false
matrix:
os:
- ubuntu-20.04
- ubuntu-18.04
- macOS-10.15
steps:
- uses: actions/checkout@v2
- name: install stack (Linux)
if: runner.os == 'Linux'
run: |
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-linux-x86_64.tar.gz | tar -xz
echo "$HOME/stack-2.5.1-linux-x86_64/" >> $GITHUB_PATH
- name: install stack (macOS)
if: runner.os == 'macOS'
run: |
curl -L https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-osx-x86_64.tar.gz | tar -xz
echo "$HOME/stack-2.5.1-osx-x86_64/" >> $GITHUB_PATH
# One of the transcripts fails if the user's git name hasn't been set.
- name: set git user info
run: |
git config --global user.name "GitHub Actions"
git config --global user.email "actions@github.com"
- name: remove ~/.stack/setup-exe-cache on macOS
if: runner.os == 'macOS'
run: rm -rf ~/.stack/setup-exe-cache
- name: build
run: stack --no-terminal build --flag unison-parser-typechecker:optimized
- name: fetch latest codebase-ui and package with ucm
run: |
mkdir -p /tmp/ucm/ui
UCM=$(stack path | awk '/local-install-root/{print $2}')/bin/unison
cp $UCM /tmp/ucm/ucm
wget -O/tmp/ucm.zip https://github.com/unisonweb/codebase-ui/releases/download/latest/ucm.zip
unzip -d /tmp/ucm/ui /tmp/ucm.zip
tar -c -z -f unison-${{runner.os}}.tar.gz -C /tmp/ucm .
- name: Set env
if: runner.os == 'macOS'
run: echo "RELEASE_VERSION=release/${GITHUB_REF#refs/tags/release/*}-${{runner.os}}" >> $GITHUB_ENV
- name: Set env
if: runner.os != 'macOS'
run: echo "RELEASE_VERSION=release/${GITHUB_REF#refs/tags/release/*}-${{matrix.os}}" >> $GITHUB_ENV
- name: "Upload ${{matrix.os}}"
uses: "actions/upload-artifact@v2"
with:
path: "unison-${{runner.os}}.tar.gz"
env:
GITHUB_TOKEN: "${{ secrets.GITHUB_TOKEN }}"

1
CONTRIBUTORS.markdown
View File

@ -51,3 +51,4 @@ The format for this list: name, GitHub handle, and then optional blurb about wha
* Sam Roberts (@samgqroberts)
* Nigel Farrelly (@nini-faroux)
* Johannes Huster (@JohannesHuster)
* Joseph Morag (@jmorag)

15
codebase2/codebase-sqlite/U/Codebase/Sqlite/Connection.hs Normal file
View File

@ -0,0 +1,15 @@
module U.Codebase.Sqlite.Connection where
import qualified Database.SQLite.Simple as Sqlite
data Connection = Connection {name :: String, file :: FilePath, underlying :: Sqlite.Connection}
instance Show Connection where
show (Connection name file underlying) =
"Connection " ++ show name
++ (if showFile then " " ++ file else mempty)
++ (if showHandle then " " ++ show (Sqlite.connectionHandle underlying) else mempty)
showFile, showHandle :: Bool
showFile = False
showHandle = False

2
codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs
View File

@ -48,7 +48,6 @@ import Data.Traversable (for)
import Data.Tuple.Extra (uncurry3)
import qualified Data.Vector as Vector
import Data.Word (Word64)
import Database.SQLite.Simple (Connection)
import Debug.Trace
import GHC.Stack (HasCallStack)
import qualified U.Codebase.Branch as C.Branch
@ -71,6 +70,7 @@ import qualified U.Codebase.Sqlite.Branch.Format as S.BranchFormat
import qualified U.Codebase.Sqlite.Branch.Full as S
import qualified U.Codebase.Sqlite.Branch.Full as S.Branch.Full
import qualified U.Codebase.Sqlite.Branch.Full as S.MetadataSet
import U.Codebase.Sqlite.Connection (Connection)
import qualified U.Codebase.Sqlite.DbId as Db
import qualified U.Codebase.Sqlite.Decl.Format as S.Decl
import U.Codebase.Sqlite.LocalIds

45
codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs
View File

@ -23,6 +23,7 @@ import Control.Monad.Except (MonadError)
import qualified Control.Monad.Except as Except
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Reader (MonadReader (ask))
import qualified Control.Monad.Reader as Reader
import Control.Monad.Trans (MonadIO (liftIO))
import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT)
import qualified Control.Monad.Writer as Writer
@ -40,8 +41,7 @@ import Data.String (fromString)
import Data.String.Here.Uninterpolated (here, hereFile)
import Data.Text (Text)
import Database.SQLite.Simple
( Connection,
FromRow,
( FromRow,
Only (..),
ToRow (..),
(:.) (..),
@ -54,6 +54,8 @@ import GHC.Stack (HasCallStack)
import Safe (headMay)
import U.Codebase.HashTags (BranchHash (..), CausalHash (..))
import U.Codebase.Reference (Reference')
import U.Codebase.Sqlite.Connection (Connection)
import qualified U.Codebase.Sqlite.Connection as Connection
import U.Codebase.Sqlite.DbId
( BranchHashId (..),
BranchObjectId (..),
@ -76,7 +78,6 @@ import U.Util.Hash (Hash)
import qualified U.Util.Hash as Hash
import UnliftIO (MonadUnliftIO, throwIO, try, tryAny, withRunInIO)
import UnliftIO.Concurrent (myThreadId)
-- * types
type DB m = (MonadIO m, MonadReader Connection m)
@ -85,11 +86,10 @@ type EDB m = (DB m, Err m)
type Err m = (MonadError Integrity m, HasCallStack)
debugQuery, debugThread, debugConnection, debugFile :: Bool
debugQuery, debugThread, debugConnection :: Bool
debugQuery = False
debugThread = False
debugConnection = False
debugFile = False
alwaysTraceOnCrash :: Bool
alwaysTraceOnCrash = True
@ -144,7 +144,7 @@ setFlags = do
{- ORMOLU_DISABLE -}
schemaVersion :: DB m => m SchemaVersion
schemaVersion = queryAtoms sql () >>= \case
schemaVersion = queryAtoms_ sql >>= \case
[] -> error $ show NoSchemaVersion
[v] -> pure v
vs -> error $ show (MultipleSchemaVersions vs)
@ -595,7 +595,7 @@ before chId1 chId2 = fmap fromOnly . queryOne $ queryMaybe sql (chId2, chId1)
-- the `Connection` arguments come second to fit the shape of Exception.bracket + uncurry curry
lca :: CausalHashId -> CausalHashId -> Connection -> Connection -> IO (Maybe CausalHashId)
lca x y _ _ | debugQuery && trace ("Q.lca " ++ show x ++ " " ++ show y) False = undefined
lca x y cx cy = Exception.bracket open close \(sx, sy) -> do
lca x y (Connection.underlying -> cx) (Connection.underlying -> cy) = Exception.bracket open close \(sx, sy) -> do
SQLite.bind sx (Only x)
SQLite.bind sy (Only y)
let getNext = (,) <$> SQLite.nextRow sx <*> SQLite.nextRow sy
@ -643,6 +643,10 @@ ancestorSql = [here|
queryAtoms :: (DB f, ToRow q, FromField b, Show q, Show b) => SQLite.Query -> q -> f [b]
queryAtoms q r = map fromOnly <$> query q r
-- | no input, atomic List output
queryAtoms_ :: (DB f, FromField b, Show b) => SQLite.Query -> f [b]
queryAtoms_ q = map fromOnly <$> query_ q
-- | composite input, composite Maybe output
queryMaybe :: (DB f, ToRow q, FromRow b, Show q, Show b) => SQLite.Query -> q -> f (Maybe b)
queryMaybe q r = headMay <$> query q r
@ -658,23 +662,21 @@ queryOne = fmap fromJust
-- | composite input, composite List output
query :: (DB m, ToRow q, FromRow r, Show q, Show r) => SQLite.Query -> q -> m [r]
query q r = do
c <- ask
c <- Reader.reader Connection.underlying
header <- debugHeader
when debugFile traceConnectionFile
liftIO . queryTrace (header ++ " query") q r $ SQLite.query c q r
-- | no input, composite List output
query_ :: (DB m, FromRow r, Show r) => SQLite.Query -> m [r]
query_ q = do
c <- ask
c <- Reader.reader Connection.underlying
header <- debugHeader
when debugFile traceConnectionFile
liftIO . queryTrace_ (header ++ " query") q $ SQLite.query_ c q
debugHeader :: DB m => m String
debugHeader = fmap (List.intercalate ", ") $ Writer.execWriterT do
when debugThread $ Writer.tell . pure . show =<< myThreadId
when debugConnection $ Writer.tell . pure . show . SQLite.connectionHandle =<< ask
when debugConnection $ Writer.tell . pure . show =<< ask
queryTrace :: (MonadUnliftIO m, Show q, Show a) => String -> SQLite.Query -> q -> m a -> m a
queryTrace title query input m = do
@ -684,7 +686,8 @@ queryTrace title query input m = do
do
try @_ @SQLite.SQLError m >>= \case
Right a -> do
when debugQuery . traceM $ showInput ++ "\n output: " ++ show a
when debugQuery . traceM $ showInput ++
if " execute" `List.isSuffixOf` title then mempty else "\n output: " ++ show a
pure a
Left e -> do
traceM $ showInput ++ "\n(and crashed)\n"
@ -697,7 +700,8 @@ queryTrace_ title query m =
then
tryAny @_ m >>= \case
Right a -> do
when debugQuery . traceM $ title ++ " " ++ show query ++ "\n output: " ++ show a
when debugQuery . traceM $ title ++ " " ++ show query ++
if " execute_" `List.isSuffixOf` title then mempty else "\n output: " ++ show a
pure a
Left e -> do
traceM $ title ++ " " ++ show query ++ "\n(and crashed)\n"
@ -706,36 +710,33 @@ queryTrace_ title query m =
traceConnectionFile :: DB m => m ()
traceConnectionFile = do
c <- ask
c <- Reader.reader Connection.underlying
liftIO (SQLite.query_ c "PRAGMA database_list;") >>= \case
[(_seq :: Int, _name :: String, file)] -> traceM file
x -> error $ show x
execute :: (DB m, ToRow q, Show q) => SQLite.Query -> q -> m ()
execute q r = do
c <- ask
c <- Reader.reader Connection.underlying
header <- debugHeader
when debugFile traceConnectionFile
liftIO . queryTrace (header ++ " " ++ "execute") q r $ SQLite.execute c q r
execute_ :: DB m => SQLite.Query -> m ()
execute_ q = do
c <- ask
c <- Reader.reader Connection.underlying
header <- debugHeader
when debugFile traceConnectionFile
liftIO . queryTrace_ (header ++ " " ++ "execute_") q $ SQLite.execute_ c q
executeMany :: (DB m, ToRow q, Show q) => SQLite.Query -> [q] -> m ()
executeMany q r = do
c <- ask
c <- Reader.reader Connection.underlying
header <- debugHeader
when debugFile traceConnectionFile
liftIO . queryTrace (header ++ " " ++ "executeMany") q r $ SQLite.executeMany c q r
-- | transaction that blocks
withImmediateTransaction :: (DB m, MonadUnliftIO m) => m a -> m a
withImmediateTransaction action = do
c <- ask
c <- Reader.reader Connection.underlying
withRunInIO \run -> SQLite.withImmediateTransaction c (run action)

2
codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs
View File

@ -29,10 +29,10 @@ import Data.List.Extra (nubOrd)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Database.SQLite.Simple (Connection)
import Debug.Trace (traceM, trace)
import qualified U.Codebase.Reference as Reference
import qualified U.Codebase.Sqlite.Branch.Format as BL
import U.Codebase.Sqlite.Connection (Connection)
import U.Codebase.Sqlite.DbId
import qualified U.Codebase.Sqlite.LocalIds as L
import qualified U.Codebase.Sqlite.ObjectType as OT

3
codebase2/codebase-sqlite/unison-codebase-sqlite.cabal
View File

@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
-- hash: 1ebfb83fff5576c08030523940c272f5edfa0f42248d67da4edc9aa6d887cf5f
-- hash: 3106bd32bedf162883882818669a81a3e1ca7c60af26ec9cd945fadb39f0d5aa
name: unison-codebase-sqlite
version: 0.0.0
@ -23,6 +23,7 @@ library
U.Codebase.Sqlite.Branch.Diff
U.Codebase.Sqlite.Branch.Format
U.Codebase.Sqlite.Branch.Full
U.Codebase.Sqlite.Connection
U.Codebase.Sqlite.DbId
U.Codebase.Sqlite.Decl.Format
U.Codebase.Sqlite.JournalMode

2
parser-typechecker/package.yaml
View File

@ -21,7 +21,7 @@ ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synony
flags:
optimized:
manual: true
default: false
default: true
when:
- condition: flag(optimized)

2
parser-typechecker/src/Unison/Codebase/Conversion/Sync12.hs
View File

@ -33,10 +33,10 @@ import qualified Data.Map as Map
import Data.Maybe (catMaybes)
import qualified Data.Set as Set
import Data.Traversable (for)
import Database.SQLite.Simple (Connection)
import Debug.Trace (traceM)
import System.IO (stdout)
import System.IO.Extra (hFlush)
import U.Codebase.Sqlite.Connection (Connection)
import U.Codebase.Sync (Sync (Sync), TrySyncResult)
import qualified U.Codebase.Sync as Sync
import qualified U.Util.Monoid as Monoid

7
parser-typechecker/src/Unison/Codebase/Conversion/Upgrade12.hs
View File

@ -34,9 +34,9 @@ syncWatchKinds = [WK.TestWatch]
upgradeCodebase :: forall m. (MonadIO m, MonadCatch m) => CodebasePath -> m ()
upgradeCodebase root = do
either (liftIO . CT.putPrettyLn) pure =<< runExceptT do
(cleanupSrc, srcCB) <- ExceptT $ Codebase.openCodebase FC.init root
(cleanupDest, destCB) <- ExceptT $ Codebase.createCodebase SC.init root
destDB <- SC.unsafeGetConnection root
(cleanupSrc, srcCB) <- ExceptT $ Codebase.openCodebase FC.init "upgradeCodebase srcCB" root
(cleanupDest, destCB) <- ExceptT $ Codebase.createCodebase SC.init "upgradeCodebase destCB" root
destDB <- SC.unsafeGetConnection "upgradeCodebase destDB" root
let env = Sync12.Env srcCB destCB destDB
let initialState = (Sync12.emptyDoneCount, Sync12.emptyErrorCount, Sync12.emptyStatus)
rootEntity <-
@ -62,6 +62,7 @@ upgradeCodebase root = do
Just (Sync12.BranchReplaced _h' c') -> pure c'
Nothing -> error "We didn't sync the root?"
_ -> error "The root wasn't a causal?"
SC.shutdownConnection destDB
lift cleanupSrc
lift cleanupDest
pure ()

5
parser-typechecker/src/Unison/Codebase/FileCodebase.hs
View File

@ -9,6 +9,7 @@ module Unison.Codebase.FileCodebase
(
codebase1', -- used by Test/Git
Unison.Codebase.FileCodebase.init,
openCodebase -- since init requires a bunch of irrelevant args now
)
where
@ -94,8 +95,8 @@ import UnliftIO.STM (atomically)
init :: (MonadIO m, MonadCatch m) => Codebase.Init m Symbol Ann
init = Codebase.Init
((fmap . fmap) (pure (),) . openCodebase)
((fmap . fmap) (pure (),) . createCodebase)
(const $ (fmap . fmap) (pure (),) . openCodebase)
(const $ (fmap . fmap) (pure (),) . createCodebase)
(</> Common.codebasePath)

56
parser-typechecker/src/Unison/Codebase/Init.hs
View File

@ -3,7 +3,6 @@
module Unison.Codebase.Init where
import qualified Data.Text as Text
import System.Exit (exitFailure)
import Unison.Codebase (Codebase, CodebasePath)
import qualified Unison.Codebase as Codebase
@ -13,7 +12,6 @@ import qualified Unison.PrettyTerminal as PT
import Unison.Symbol (Symbol)
import qualified Unison.Util.Pretty as P
import UnliftIO.Directory (canonicalizePath)
import UnliftIO.Environment (getProgName)
type Pretty = P.Pretty P.ColorText
@ -21,20 +19,22 @@ data CreateCodebaseError
= CreateCodebaseAlreadyExists
| CreateCodebaseOther Pretty
type DebugName = String
data Init m v a = Init
{ -- | open an existing codebase
openCodebase :: CodebasePath -> m (Either Pretty (m (), Codebase m v a)),
openCodebase :: DebugName -> CodebasePath -> m (Either Pretty (m (), Codebase m v a)),
-- | create a new codebase
createCodebase' :: CodebasePath -> m (Either CreateCodebaseError (m (), Codebase m v a)),
createCodebase' :: DebugName -> CodebasePath -> m (Either CreateCodebaseError (m (), Codebase m v a)),
-- | given a codebase root, and given that the codebase root may have other junk in it,
-- give the path to the "actual" files; e.g. what a forked transcript should clone.
codebasePath :: CodebasePath -> CodebasePath
}
createCodebase :: MonadIO m => Init m v a -> CodebasePath -> m (Either Pretty (m (), Codebase m v a))
createCodebase cbInit path = do
createCodebase :: MonadIO m => Init m v a -> DebugName -> CodebasePath -> m (Either Pretty (m (), Codebase m v a))
createCodebase debugName cbInit path = do
prettyDir <- P.string <$> canonicalizePath path
createCodebase' cbInit path <&> mapLeft \case
createCodebase' debugName cbInit path <&> mapLeft \case
CreateCodebaseAlreadyExists ->
P.wrap $
"It looks like there's already a codebase in: "
@ -49,42 +49,12 @@ createCodebase cbInit path = do
-- * compatibility stuff
-- | load an existing codebase or exit.
getCodebaseOrExit :: MonadIO m => Init m v a -> Maybe CodebasePath -> m (m (), Codebase m v a)
getCodebaseOrExit init mdir = do
dir <- Codebase.getCodebaseDir mdir
openCodebase init dir >>= \case
Left _e -> liftIO do
progName <- getProgName
prettyDir <- P.string <$> canonicalizePath dir
PT.putPrettyLn' $ getNoCodebaseErrorMsg ((P.text . Text.pack) progName) prettyDir mdir
exitFailure
Right x -> pure x
where
getNoCodebaseErrorMsg :: IsString s => P.Pretty s -> P.Pretty s -> Maybe FilePath -> P.Pretty s
getNoCodebaseErrorMsg executable prettyDir mdir =
let secondLine =
case mdir of
Just dir ->
"Run `" <> executable <> " -codebase " <> fromString dir
<> " init` to create one, then try again!"
Nothing ->
"Run `" <> executable <> " init` to create one there,"
<> " then try again;"
<> " or `"
<> executable
<> " -codebase <dir>` to load a codebase from someplace else!"
in P.lines
[ "No codebase exists in " <> prettyDir <> ".",
secondLine
]
-- previously: initCodebaseOrExit :: CodebasePath -> m (m (), Codebase m v a)
-- previously: FileCodebase.initCodebase :: CodebasePath -> m (m (), Codebase m v a)
openNewUcmCodebaseOrExit :: MonadIO m => Init m Symbol Ann -> CodebasePath -> m (m (), Codebase m Symbol Ann)
openNewUcmCodebaseOrExit cbInit path = do
openNewUcmCodebaseOrExit :: MonadIO m => Init m Symbol Ann -> DebugName -> CodebasePath -> m (m (), Codebase m Symbol Ann)
openNewUcmCodebaseOrExit debugName cbInit path = do
prettyDir <- P.string <$> canonicalizePath path
createCodebase cbInit path >>= \case
createCodebase debugName cbInit path >>= \case
Left error -> liftIO $ PT.putPrettyLn' error >> exitFailure
Right x@(_, codebase) -> do
liftIO $
@ -96,6 +66,6 @@ openNewUcmCodebaseOrExit cbInit path = do
pure x
-- | try to init a codebase where none exists and then exit regardless (i.e. `ucm -codebase dir init`)
initCodebaseAndExit :: MonadIO m => Init m Symbol Ann -> Maybe CodebasePath -> m ()
initCodebaseAndExit i mdir =
void $ openNewUcmCodebaseOrExit i =<< Codebase.getCodebaseDir mdir
initCodebaseAndExit :: MonadIO m => Init m Symbol Ann -> DebugName -> Maybe CodebasePath -> m ()
initCodebaseAndExit i debugName mdir =
void $ openNewUcmCodebaseOrExit i debugName =<< Codebase.getCodebaseDir mdir

200
parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs
View File

@ -6,7 +6,12 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.Codebase.SqliteCodebase (Unison.Codebase.SqliteCodebase.init, unsafeGetConnection) where
module Unison.Codebase.SqliteCodebase
( Unison.Codebase.SqliteCodebase.init,
unsafeGetConnection,
shutdownConnection,
)
where
import qualified Control.Concurrent
import qualified Control.Exception
@ -22,6 +27,7 @@ import Control.Monad.Trans (MonadTrans (lift))
import Control.Monad.Trans.Maybe (MaybeT (MaybeT))
import Data.Bifunctor (Bifunctor (bimap, first), second)
import qualified Data.Either.Combinators as Either
import qualified Data.Char as Char
import Data.Foldable (Foldable (toList), for_, traverse_)
import Data.Functor (void, (<&>), ($>))
import qualified Data.List as List
@ -35,7 +41,6 @@ import qualified Data.Text as Text
import qualified Data.Text.IO as TextIO
import Data.Traversable (for)
import Data.Word (Word64)
import Database.SQLite.Simple (Connection)
import qualified Database.SQLite.Simple as Sqlite
import GHC.Stack (HasCallStack)
import qualified System.Console.ANSI as ANSI
@ -44,6 +49,9 @@ import qualified System.FilePath as FilePath
import U.Codebase.HashTags (CausalHash (CausalHash, unCausalHash))
import U.Codebase.Sqlite.Operations (EDB)
import qualified U.Codebase.Reference as C.Reference
import U.Codebase.Sqlite.Connection (Connection (Connection))
import qualified U.Codebase.Sqlite.Connection as Connection
import qualified U.Codebase.Sqlite.JournalMode as JournalMode
import qualified U.Codebase.Sqlite.ObjectType as OT
import qualified U.Codebase.Sqlite.Operations as Ops
import qualified U.Codebase.Sqlite.Queries as Q
@ -115,9 +123,10 @@ init = Codebase.Init getCodebaseOrError createCodebaseOrError v2dir
createCodebaseOrError ::
(MonadIO m, MonadCatch m) =>
Codebase.DebugName ->
CodebasePath ->
m (Either Codebase1.CreateCodebaseError (m (), Codebase m Symbol Ann))
createCodebaseOrError dir = do
createCodebaseOrError debugName dir = do
prettyDir <- P.string <$> canonicalizePath dir
let convertError = \case
CreateCodebaseAlreadyExists -> Codebase1.CreateCodebaseAlreadyExists
@ -125,7 +134,7 @@ createCodebaseOrError dir = do
prettyError :: SchemaVersion -> Codebase1.Pretty
prettyError v = P.wrap $
"I don't know how to handle " <> P.shown v <> "in" <> P.backticked' prettyDir "."
Either.mapLeft convertError <$> createCodebaseOrError' dir
Either.mapLeft convertError <$> createCodebaseOrError' debugName dir
data CreateCodebaseError
= CreateCodebaseAlreadyExists
@ -134,9 +143,10 @@ data CreateCodebaseError
createCodebaseOrError' ::
(MonadIO m, MonadCatch m) =>
Codebase.DebugName ->
CodebasePath ->
m (Either CreateCodebaseError (m (), Codebase m Symbol Ann))
createCodebaseOrError' path = do
createCodebaseOrError' debugName path = do
ifM
(doesFileExist $ path </> codebasePath)
(pure $ Left CreateCodebaseAlreadyExists)
@ -144,8 +154,8 @@ createCodebaseOrError' path = do
createDirectoryIfMissing True (path </> FilePath.takeDirectory codebasePath)
liftIO $
Control.Exception.bracket
(unsafeGetConnection path)
Sqlite.close
(unsafeGetConnection (debugName ++ ".createSchema") path)
shutdownConnection
(runReaderT do
Q.createSchema
runExceptT (void . Ops.saveRootBranch $ Cv.causalbranch1to2 Branch.empty) >>= \case
@ -153,26 +163,25 @@ createCodebaseOrError' path = do
Right () -> pure ()
)
fmap (Either.mapLeft CreateCodebaseUnknownSchemaVersion) (sqliteCodebase path)
fmap (Either.mapLeft CreateCodebaseUnknownSchemaVersion) (sqliteCodebase debugName path)
openOrCreateCodebaseConnection :: MonadIO m => FilePath -> m Connection
openOrCreateCodebaseConnection path = do
openOrCreateCodebaseConnection :: MonadIO m => Codebase.DebugName -> FilePath -> m Connection
openOrCreateCodebaseConnection debugName path = do
unlessM
(doesFileExist $ path </> codebasePath)
(initSchemaIfNotExist path)
unsafeGetConnection path
unsafeGetConnection debugName path
-- get the codebase in dir
getCodebaseOrError :: forall m. (MonadIO m, MonadCatch m) => CodebasePath -> m (Either Codebase1.Pretty (m (), Codebase m Symbol Ann))
getCodebaseOrError dir = do
getCodebaseOrError :: forall m. (MonadIO m, MonadCatch m) => Codebase.DebugName -> CodebasePath -> m (Either Codebase1.Pretty (m (), Codebase m Symbol Ann))
getCodebaseOrError debugName dir = do
prettyDir <- liftIO $ P.string <$> canonicalizePath dir
let prettyError v = P.wrap $ "I don't know how to handle " <> P.shown v <> "in" <> P.backticked' prettyDir "."
doesFileExist (dir </> codebasePath) >>= \case
-- If the codebase file doesn't exist, just return any string. The string is currently ignored (see
-- Unison.Codebase.Init.getCodebaseOrExit).
False -> pure (Left "codebase doesn't exist")
True -> fmap (Either.mapLeft prettyError) (sqliteCodebase dir)
True -> fmap (Either.mapLeft prettyError) (sqliteCodebase debugName dir)
initSchemaIfNotExist :: MonadIO m => FilePath -> m ()
initSchemaIfNotExist path = liftIO do
@ -180,8 +189,8 @@ initSchemaIfNotExist path = liftIO do
createDirectoryIfMissing True (path </> FilePath.takeDirectory codebasePath)
unlessM (doesFileExist $ path </> codebasePath) $
Control.Exception.bracket
(unsafeGetConnection path)
Sqlite.close
(unsafeGetConnection "initSchemaIfNotExist" path)
shutdownConnection
(runReaderT Q.createSchema)
-- checks if a db exists at `path` with the minimum schema
@ -189,9 +198,9 @@ codebaseExists :: MonadIO m => CodebasePath -> m Bool
codebaseExists root = liftIO do
Monad.when debug $ traceM $ "codebaseExists " ++ root
Control.Exception.catch @Sqlite.SQLError
( sqliteCodebase root >>= \case
( sqliteCodebase "codebaseExists" root >>= \case
Left _ -> pure False
Right (close, _codebase) -> close >> pure True
Right (close, _codebase) -> close $> True
)
(const $ pure False)
@ -244,17 +253,23 @@ type TermBufferEntry = BufferEntry (Term Symbol Ann, Type Symbol Ann)
type DeclBufferEntry = BufferEntry (Decl Symbol Ann)
unsafeGetConnection :: MonadIO m => CodebasePath -> m Sqlite.Connection
unsafeGetConnection root = do
Monad.when debug $ traceM $ "unsafeGetconnection " ++ root ++ " -> " ++ (root </> codebasePath)
conn <- liftIO . Sqlite.open $ root </> codebasePath
unsafeGetConnection :: MonadIO m => Codebase.DebugName -> CodebasePath -> m Connection
unsafeGetConnection name root = do
let path = root </> codebasePath
Monad.when debug $ traceM $ "unsafeGetconnection " ++ name ++ " " ++ root ++ " -> " ++ path
(Connection name path -> conn) <- liftIO $ Sqlite.open path
runReaderT Q.setFlags conn
pure conn
sqliteCodebase :: (MonadIO m, MonadCatch m) => CodebasePath -> m (Either SchemaVersion (m (), Codebase m Symbol Ann))
sqliteCodebase root = do
Monad.when debug $ traceM $ "sqliteCodebase " ++ root
conn <- unsafeGetConnection root
shutdownConnection :: MonadIO m => Connection -> m ()
shutdownConnection conn = do
Monad.when debug $ traceM $ "shutdown connection " ++ show conn
liftIO $ Sqlite.close (Connection.underlying conn)
sqliteCodebase :: (MonadIO m, MonadCatch m) => Codebase.DebugName -> CodebasePath -> m (Either SchemaVersion (m (), Codebase m Symbol Ann))
sqliteCodebase debugName root = do
Monad.when debug $ traceM $ "sqliteCodebase " ++ debugName ++ " " ++ root
conn <- unsafeGetConnection debugName root
termCache <- Cache.semispaceCache 8192 -- pure Cache.nullCache -- to disable
typeOfTermCache <- Cache.semispaceCache 8192
declCache <- Cache.semispaceCache 1024
@ -572,14 +587,14 @@ sqliteCodebase root = do
syncFromDirectory :: MonadIO m => Codebase1.CodebasePath -> SyncMode -> Branch m -> m ()
syncFromDirectory srcRoot _syncMode b =
flip State.evalStateT emptySyncProgressState $ do
srcConn <- unsafeGetConnection srcRoot
srcConn <- unsafeGetConnection (debugName ++ ".sync.src") srcRoot
syncInternal syncProgress srcConn conn $ Branch.transform lift b
syncToDirectory :: MonadIO m => Codebase1.CodebasePath -> SyncMode -> Branch m -> m ()
syncToDirectory destRoot _syncMode b =
flip State.evalStateT emptySyncProgressState $ do
initSchemaIfNotExist destRoot
destConn <- unsafeGetConnection destRoot
destConn <- unsafeGetConnection (debugName ++ ".sync.dest") destRoot
syncInternal syncProgress conn destConn $ Branch.transform lift b
watches :: MonadIO m => UF.WatchKind -> m [Reference.Id]
@ -697,12 +712,13 @@ sqliteCodebase root = do
. (fmap . fmap) Cv.causalHash2to1
$ Ops.lca (Cv.causalHash1to2 h1) (Cv.causalHash1to2 h2) c1 c2
where
open = (,) <$> unsafeGetConnection root <*> unsafeGetConnection root
close (c1, c2) = Sqlite.close c1 *> Sqlite.close c2
open = (,) <$> unsafeGetConnection (debugName ++ ".lca.left") root
<*> unsafeGetConnection (debugName ++ ".lca.left") root
close (c1, c2) = shutdownConnection c1 *> shutdownConnection c2
let finalizer :: MonadIO m => m ()
finalizer = do
liftIO $ Sqlite.close conn
shutdownConnection conn
decls <- readTVarIO declBuffer
terms <- readTVarIO termBuffer
let printBuffer header b =
@ -753,7 +769,7 @@ sqliteCodebase root = do
(Just \l r -> runDB conn $ fromJust <$> before l r)
in code
)
v -> liftIO $ Sqlite.close conn $> Left v
v -> shutdownConnection conn $> Left v
-- well one or the other. :zany_face: the thinking being that they wouldn't hash-collide
termExists', declExists' :: MonadIO m => Hash -> ReaderT Connection (ExceptT Ops.Error m) Bool
@ -836,17 +852,19 @@ syncInternal progress srcConn destConn b = time "syncInternal" do
traceM $ " decls: " ++ show ds
traceM $ " edits: " ++ show es
(cs, es, ts, ds) <- lift $ runDB destConn do
cs <- filterM (fmap not . runDB destConn . isCausalHash' . fst) branchDeps
es <- filterM (fmap not . runDB destConn . patchExists') es
ts <- filterM (fmap not . runDB destConn . termExists') ts
ds <- filterM (fmap not . runDB destConn . declExists') ds
cs <- filterM (fmap not . isCausalHash' . fst) branchDeps
es <- filterM (fmap not . patchExists') es
ts <- filterM (fmap not . termExists') ts
ds <- filterM (fmap not . declExists') ds
pure (cs, es, ts, ds)
if null cs && null es && null ts && null ds
then lift . runDB destConn $ putBranch' b
else
let bs = map (uncurry B) branchDeps
then do
lift . runDB destConn $ putBranch' b
processBranches @m sync progress rest
else do
let bs = map (uncurry B) cs
os = map O (es <> ts <> ds)
in processBranches @m sync progress (os ++ bs ++ B h mb : rest)
processBranches @m sync progress (os ++ bs ++ b0 : rest)
processBranches sync progress (O h : rest) = do
when debugProcessBranches $ traceM $ "processBranches O " ++ take 10 (show h)
(runExceptT $ flip runReaderT srcConn (Q.expectHashIdByHash (Cv.hash1to2 h) >>= Q.expectObjectIdForAnyHashId)) >>= \case
@ -978,7 +996,7 @@ viewRemoteBranch' (repo, sbh, path) = runExceptT do
ifM
(codebaseExists remotePath)
do
lift (sqliteCodebase remotePath) >>= \case
lift (sqliteCodebase "viewRemoteBranch.gitCache" remotePath) >>= \case
Left sv -> ExceptT . pure . Left $ GitError.UnrecognizedSchemaVersion repo remotePath sv
Right (closeCodebase, codebase) -> do
-- try to load the requested branch from it
@ -1027,7 +1045,7 @@ pushGitRootBranch srcConn branch repo = runExceptT @GitError do
-- set up the cache dir
remotePath <- time "Git fetch" $ pullBranch repo
destConn <- openOrCreateCodebaseConnection remotePath
destConn <- openOrCreateCodebaseConnection "push.dest" remotePath
flip runReaderT destConn $ Q.savepoint "push"
lift . flip State.execStateT emptySyncProgressState $
@ -1057,10 +1075,11 @@ pushGitRootBranch srcConn branch repo = runExceptT @GitError do
setRepoRoot newRootHash
Q.release "push"
liftIO do
Sqlite.close destConn
void $ push remotePath repo
Q.setJournalMode JournalMode.DELETE
liftIO do
shutdownConnection destConn
void $ push remotePath repo
where
repoString = Text.unpack $ printRepo repo
setRepoRoot :: Q.DB m => Branch.Hash -> m ()
@ -1070,27 +1089,80 @@ pushGitRootBranch srcConn branch repo = runExceptT @GitError do
chId <- fromMaybe err <$> Q.loadCausalHashIdByCausalHash h2
Q.setNamespaceRoot chId
-- This function makes sure that the result of git status is valid.
-- Valid lines are any of:
--
-- ?? .unison/v2/unison.sqlite3 (initial commit to an empty repo)
-- M .unison/v2/unison.sqlite3 (updating an existing repo)
-- D .unison/v2/unison.sqlite3-wal (cleaning up the WAL from before bugfix)
-- D .unison/v2/unison.sqlite3-shm (ditto)
--
-- Invalid lines are like:
--
-- ?? .unison/v2/unison.sqlite3-wal
--
-- Which will only happen if the write-ahead log hasn't been
-- fully folded into the unison.sqlite3 file.
--
-- Returns `Just (hasDeleteWal, hasDeleteShm)` on success,
-- `Nothing` otherwise. hasDeleteWal means there's the line:
-- D .unison/v2/unison.sqlite3-wal
-- and hasDeleteShm is `True` if there's the line:
-- D .unison/v2/unison.sqlite3-shm
--
parseStatus :: Text -> Maybe (Bool, Bool)
parseStatus status =
if all okLine statusLines then Just (hasDeleteWal, hasDeleteShm)
else Nothing
where
statusLines = Text.unpack <$> Text.lines status
t = dropWhile Char.isSpace
okLine (t -> '?' : '?' : (t -> p)) | p == codebasePath = True
okLine (t -> 'M' : (t -> p)) | p == codebasePath = True
okLine line = isWalDelete line || isShmDelete line
isWalDelete (t -> 'D' : (t -> p)) | p == codebasePath ++ "-wal" = True
isWalDelete _ = False
isShmDelete (t -> 'D' : (t -> p)) | p == codebasePath ++ "-wal" = True
isShmDelete _ = False
hasDeleteWal = any isWalDelete statusLines
hasDeleteShm = any isShmDelete statusLines
-- Commit our changes
push :: CodebasePath -> RemoteRepo -> IO Bool -- withIOError needs IO
push remotePath (GitRepo url gitbranch) = time "SqliteCodebase.pushGitRootBranch.push" $ do
-- has anything changed?
status <- gitTextIn remotePath ["status", "--short"]
-- note: -uall recursively shows status for all files in untracked directories
-- we want this so that we see
-- `?? .unison/v2/unison.sqlite3` and not
-- `?? .unison/`
status <- gitTextIn remotePath ["status", "--short", "-uall"]
if Text.null status
then pure False
else do
gitIn remotePath ["add", "--all", "."]
gitIn
remotePath
["commit", "-q", "-m", "Sync branch " <> Text.pack (show $ Branch.headHash branch)]
-- Push our changes to the repo
case gitbranch of
Nothing -> gitIn remotePath ["push", "--quiet", url]
Just gitbranch ->
error $
"Pushing to a specific branch isn't fully implemented or tested yet.\n"
++ "InputPatterns.parseUri was expected to have prevented you "
++ "from supplying the git treeish `"
++ Text.unpack gitbranch
++ "`!"
-- gitIn remotePath ["push", "--quiet", url, gitbranch]
pure True
else case parseStatus status of
Nothing ->
error $ "An error occurred during push.\n"
<> "I was expecting only to see .unison/v2/unison.sqlite3 modified, but saw:\n\n"
<> Text.unpack status <> "\n\n"
<> "Please visit https://github.com/unisonweb/unison/issues/2063\n"
<> "and add any more details about how you encountered this!\n"
Just (hasDeleteWal, hasDeleteShm) -> do
-- Only stage files we're expecting; don't `git add --all .`
-- which could accidentally commit some garbage
gitIn remotePath ["add", ".unison/v2/unison.sqlite3"]
when hasDeleteWal $ gitIn remotePath ["rm", ".unison/v2/unison.sqlite3-wal"]
when hasDeleteShm $ gitIn remotePath ["rm", ".unison/v2/unison.sqlite3-shm"]
gitIn
remotePath
["commit", "-q", "-m", "Sync branch " <> Text.pack (show $ Branch.headHash branch)]
-- Push our changes to the repo
case gitbranch of
Nothing -> gitIn remotePath ["push", "--quiet", url]
Just gitbranch ->
error $
"Pushing to a specific branch isn't fully implemented or tested yet.\n"
++ "InputPatterns.parseUri was expected to have prevented you "
++ "from supplying the git treeish `"
++ Text.unpack gitbranch
++ "`!"
-- gitIn remotePath ["push", "--quiet", url, gitbranch]
pure True

12
parser-typechecker/src/Unison/TermPrinter.hs
View File

@ -122,6 +122,8 @@ data DocLiteralContext
>=10
10f 10x 10y ...
termLink t
typeLink t
>=3
x -> 2y
@ -177,11 +179,13 @@ pretty0
where name = elideFQN im $ HQ.unsafeFromVar (Var.reset v)
Ref' r -> parenIfInfix name ic $ styleHashQualified'' (fmt $ S.Reference r) name
where name = elideFQN im $ PrettyPrintEnv.termName n (Referent.Ref r)
TermLink' r -> parenIfInfix name ic $
fmt S.LinkKeyword "termLink " <> styleHashQualified'' (fmt $ S.Referent r) name
TermLink' r -> paren (p >= 10) $
fmt S.LinkKeyword "termLink " <>
(parenIfInfix name ic $ styleHashQualified'' (fmt $ S.Referent r) name)
where name = elideFQN im $ PrettyPrintEnv.termName n r
TypeLink' r -> parenIfInfix name ic $
fmt S.LinkKeyword "typeLink " <> styleHashQualified'' (fmt $ S.Reference r) name
TypeLink' r -> paren (p >= 10) $
fmt S.LinkKeyword "typeLink " <>
(parenIfInfix name ic $ styleHashQualified'' (fmt $ S.Reference r) name)
where name = elideFQN im $ PrettyPrintEnv.typeName n r
Ann' tm t ->
paren (p >= 0)

31
parser-typechecker/src/Unison/Util/Less.hs
View File

@ -1,5 +1,6 @@
module Unison.Util.Less where
import System.Environment (lookupEnv)
import System.Process
import System.IO (hPutStr, hClose)
import Control.Exception.Extra (ignore)
@ -7,19 +8,23 @@ import Unison.Prelude (void)
less :: String -> IO ()
less str = do
let args = ["--no-init" -- don't clear the screen on exit
,"--raw-control-chars" -- pass through colors and stuff
,"--prompt=[less] Use space/arrow keys to navigate, or 'q' to return to ucm:"
,"--quit-if-one-screen" -- self-explanatory
]
(Just stdin, _stdout, _stderr, pid)
<- createProcess (proc "less" args) { std_in = CreatePipe }
inEmacs <- lookupEnv "INSIDE_EMACS"
case inEmacs of
Just _ -> putStr str
Nothing -> do
let args = ["--no-init" -- don't clear the screen on exit
,"--raw-control-chars" -- pass through colors and stuff
,"--prompt=[less] Use space/arrow keys to navigate, or 'q' to return to ucm:"
,"--quit-if-one-screen" -- self-explanatory
]
(Just stdin, _stdout, _stderr, pid)
<- createProcess (proc "less" args) { std_in = CreatePipe }
-- If `less` exits before consuming all of stdin, `hPutStr` will crash.
ignore $ hPutStr stdin str
-- If `less` exits before consuming all of stdin, `hPutStr` will crash.
ignore $ hPutStr stdin str
-- If `less` has already exited, hClose throws an exception.
ignore $ hClose stdin
-- If `less` has already exited, hClose throws an exception.
ignore $ hClose stdin
-- Wait for `less` to exit.
void $ waitForProcess pid
-- Wait for `less` to exit.
void $ waitForProcess pid

45
parser-typechecker/tests/Unison/Test/GitSync.hs
View File

@ -363,6 +363,51 @@ test = scope "gitsync22" . tests $
void . fmap (fromJust . sequence) $
traverse (Codebase.getWatch cb TestWatch) =<<
Codebase.watches cb TestWatch)
,
pushPullTest "fix2068(a)" fmt
-- this triggers
{-
gitsync22.sc.fix2068(a) EXCEPTION!!!: Called SqliteCodebase.setNamespaceRoot on unknown causal hash CausalHash (fromBase32Hex "codddvgt1ep57qpdkhe2j4pe1ehlpi5iitcrludtb8ves1aaqjl453onvfphqg83vukl7bbrj49itceqfob2b3alf47u4vves5s7pog")
CallStack (from HasCallStack):
error, called at src/Unison/Codebase/SqliteCodebase.hs:1072:17 in unison-parser-typechecker-0.0.0-6U6boimwb8GAC5qrhLfs8h:Unison.Codebase.SqliteCodebase
-}
(\repo -> [i|
```ucm
.> alias.type ##Nat builtin.Nat2
.> alias.type ##Int builtin.Int2
.> push ${repo}:.foo.bar
```
|])
(\repo -> [i|
```ucm
.> pull ${repo} pulled
.> view pulled.foo.bar.builtin.Nat2
.> view pulled.foo.bar.builtin.Int2
```
|])
,
pushPullTest "fix2068(b)" fmt
-- this triggers
{-
- gitsync22.sc.fix2068(b) EXCEPTION!!!: I couldn't find the hash ndn6fa85ggqtbgffqhd4d3bca2d08pgp3im36oa8k6p257aid90ovjq75htmh7lmg7akaqneva80ml1o21iscjmp9n1uc3lmqgg9rgg that I just synced to the cached copy of /private/var/folders/6m/p3szds2j67d8vwmxr51yrf5c0000gn/T/git-simple-1047398c149d3d5c/repo.git in "/Users/pchiusano/.cache/unisonlanguage/gitfiles/$x2F$private$x2F$var$x2F$folders$x2F$6m$x2F$p3szds2j67d8vwmxr51yrf5c0000gn$x2F$T$x2F$git-simple-1047398c149d3d5c$x2F$repo$dot$git".
CallStack (from HasCallStack):
error, called at src/Unison/Codebase/SqliteCodebase.hs:1046:13 in unison-parser-typechecker-0.0.0-6U6boimwb8GAC5qrhLfs8h:Unison.Codebase.SqliteCodebase
-}
(\repo -> [i|
```ucm
.> alias.type ##Nat builtin.Nat2
.> alias.type ##Int builtin.Int2
.> push ${repo}
.> push ${repo}:.foo.bar
```
|])
(\repo -> [i|
```ucm
.> pull ${repo} pulled
.> view pulled.foo.bar.builtin.Nat2
.> view pulled.foo.bar.builtin.Int2
```
|])
-- m [Reference.Id]

8
parser-typechecker/tests/Unison/Test/Ucm.hs
View File

@ -53,8 +53,8 @@ initCodebase fmt = do
let cbInit = case fmt of CodebaseFormat1 -> FC.init; CodebaseFormat2 -> SC.init
tmp <-
Temp.getCanonicalTemporaryDirectory
>>= flip Temp.createTempDirectory ("ucm-test")
Codebase.Init.createCodebase cbInit tmp >>= \case
>>= flip Temp.createTempDirectory "ucm-test"
Codebase.Init.createCodebase cbInit "ucm-test" tmp >>= \case
Left e -> fail $ P.toANSI 80 e
Right (close, _cb) -> close
pure $ Codebase tmp fmt
@ -80,7 +80,7 @@ runTranscript (Codebase codebasePath fmt) transcript = do
let err err = fail $ "Parse error: \n" <> show err
cbInit = case fmt of CodebaseFormat1 -> FC.init; CodebaseFormat2 -> SC.init
(closeCodebase, codebase) <-
Codebase.Init.openCodebase cbInit codebasePath >>= \case
Codebase.Init.openCodebase cbInit "transcript" codebasePath >>= \case
Left e -> fail $ P.toANSI 80 e
Right x -> pure x
Codebase.installUcmDependencies codebase
@ -100,6 +100,6 @@ runTranscript (Codebase codebasePath fmt) transcript = do
lowLevel :: Codebase -> (Codebase.Codebase IO Symbol Ann -> IO a) -> IO a
lowLevel (Codebase root fmt) f = do
let cbInit = case fmt of CodebaseFormat1 -> FC.init; CodebaseFormat2 -> SC.init
Codebase.Init.openCodebase cbInit root >>= \case
Codebase.Init.openCodebase cbInit "lowLevel" root >>= \case
Left p -> PT.putPrettyLn p *> pure (error "This really should have loaded")
Right (close, cb) -> f cb <* close

2
parser-typechecker/unison-parser-typechecker.cabal
View File

@ -19,7 +19,7 @@ source-repository head
flag optimized
manual: True
default: False
default: True
library
exposed-modules:

136
parser-typechecker/unison/Main.hs
View File

@ -22,7 +22,7 @@ import Data.Configurator.Types (Config)
import qualified Data.Text as Text
import qualified GHC.Conc
import qualified Network.URI.Encode as URI
import System.Directory (getCurrentDirectory, removeDirectoryRecursive)
import System.Directory (canonicalizePath, getCurrentDirectory, removeDirectoryRecursive)
import System.Environment (getArgs, getProgName)
import qualified System.Exit as Exit
import qualified System.FilePath as FP
@ -62,7 +62,10 @@ usage executableStr = P.callout "🌻" $ P.lines [
P.wrap "Starts Unison interactively, using the codebase in the home directory.",
"",
P.bold $ executable <> " -codebase path/to/codebase",
P.wrap "Starts Unison interactively, using the specified codebase. This flag can also be set for any of the below commands.",
P.wrap "Starts Unison interactively, using the specified codebase. This flag can also be set before any of the below commands.",
"",
P.bold $ executable <> " --old-codebase",
P.wrap $ "Starts Unison using a v1 codebase. This flag can also be set before any of the below commands.",
"",
P.bold $ executable <> " run .mylib.mymain",
P.wrap "Executes the definition `.mylib.mymain` from the codebase, then exits.",
@ -100,6 +103,9 @@ usage executableStr = P.callout "🌻" $ P.lines [
<> "Multiple transcript files may be provided; they are processed in sequence"
<> "starting from the same codebase.",
"",
P.bold $ executable <> " upgrade-codebase",
"Upgrades a v1 codebase to a v2 codebase.",
"",
P.bold $ executable <> " headless",
"Runs the codebase server without the command-line interface.",
"",
@ -133,6 +139,12 @@ installSignalHandlers = do
return ()
data CodebaseFormat = V1 | V2 deriving (Eq)
cbInitFor :: CodebaseFormat -> Codebase.Init IO Symbol Ann
cbInitFor = \case V1 -> FC.init; V2 -> SC.init
main :: IO ()
main = do
args <- getArgs
@ -147,11 +159,11 @@ main = do
let (mcodepath, restargs0) = case args of
"-codebase" : codepath : restargs -> (Just codepath, restargs)
_ -> (Nothing, args)
(fromMaybe True -> newCodebase, restargs) = case restargs0 of
"--new-codebase" : rest -> (Just True, rest)
"--old-codebase" : rest -> (Just False, rest)
(fromMaybe V2 -> cbFormat, restargs) = case restargs0 of
"--new-codebase" : rest -> (Just V2, rest)
"--old-codebase" : rest -> (Just V1, rest)
_ -> (Nothing, restargs0)
cbInit = if newCodebase then SC.init else FC.init
cbInit = case cbFormat of V1 -> FC.init; V2 -> SC.init
currentDir <- getCurrentDirectory
configFilePath <- getConfigFilePath mcodepath
config <-
@ -161,9 +173,9 @@ main = do
[version] | isFlag "version" version ->
putStrLn $ progName ++ " version: " ++ Version.gitDescribe
[help] | isFlag "help" help -> PT.putPrettyLn (usage progName)
["init"] -> Codebase.initCodebaseAndExit cbInit mcodepath
["init"] -> Codebase.initCodebaseAndExit cbInit "main.init" mcodepath
"run" : [mainName] -> do
(closeCodebase, theCodebase) <- Codebase.getCodebaseOrExit cbInit mcodepath
(closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath
runtime <- RTI.startRuntime
execute theCodebase runtime mainName
closeCodebase
@ -172,7 +184,7 @@ main = do
case e of
Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I couldn't find that file or it is for some reason unreadable."
Right contents -> do
(closeCodebase, theCodebase) <- Codebase.getCodebaseOrExit cbInit mcodepath
(closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath
let fileEvent = Input.UnisonFileChanged (Text.pack file) contents
launch currentDir config theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName, Right Input.QuitI]
closeCodebase
@ -181,7 +193,7 @@ main = do
case e of
Left _ -> PT.putPrettyLn $ P.callout "⚠️" "I had trouble reading this input."
Right contents -> do
(closeCodebase, theCodebase) <- Codebase.getCodebaseOrExit cbInit mcodepath
(closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath
let fileEvent = Input.UnisonFileChanged (Text.pack "<standard input>") contents
launch
currentDir config theCodebase
@ -189,16 +201,16 @@ main = do
closeCodebase
"transcript" : args' ->
case args' of
"-save-codebase" : transcripts -> runTranscripts cbInit False True mcodepath transcripts
_ -> runTranscripts cbInit False False mcodepath args'
"-save-codebase" : transcripts -> runTranscripts cbFormat False True mcodepath transcripts
_ -> runTranscripts cbFormat False False mcodepath args'
"transcript.fork" : args' ->
case args' of
"-save-codebase" : transcripts -> runTranscripts cbInit True True mcodepath transcripts
_ -> runTranscripts cbInit True False mcodepath args'
"-save-codebase" : transcripts -> runTranscripts cbFormat True True mcodepath transcripts
_ -> runTranscripts cbFormat True False mcodepath args'
["upgrade-codebase"] -> upgradeCodebase mcodepath
args -> do
let headless = listToMaybe args == Just "headless"
(closeCodebase, theCodebase) <- Codebase.getCodebaseOrExit cbInit mcodepath
(closeCodebase, theCodebase) <- getCodebaseOrExit cbFormat mcodepath
Server.start theCodebase $ \token port -> do
let url =
"http://127.0.0.1:" <> show port <> "/" <> URI.encode (unpack token)
@ -237,12 +249,12 @@ upgradeCodebase mcodepath =
<> "but there's no rush. You can access the old codebase again by passing the"
<> P.backticked "--old-codebase" <> "flag at startup."
prepareTranscriptDir :: Codebase.Init IO Symbol Ann -> Bool -> Maybe FilePath -> IO FilePath
prepareTranscriptDir cbInit inFork mcodepath = do
prepareTranscriptDir :: CodebaseFormat -> Bool -> Maybe FilePath -> IO FilePath
prepareTranscriptDir cbFormat inFork mcodepath = do
tmp <- Temp.getCanonicalTemporaryDirectory >>= (`Temp.createTempDirectory` "transcript")
let cbInit = cbInitFor cbFormat
if inFork then
Codebase.getCodebaseOrExit cbInit mcodepath >> do
getCodebaseOrExit cbFormat mcodepath >> do
path <- Codebase.getCodebaseDir mcodepath
PT.putPrettyLn $ P.lines [
P.wrap "Transcript will be run on a copy of the codebase at: ", "",
@ -251,16 +263,16 @@ prepareTranscriptDir cbInit inFork mcodepath = do
Path.copyDir (Codebase.codebasePath cbInit path) (Codebase.codebasePath cbInit tmp)
else do
PT.putPrettyLn . P.wrap $ "Transcript will be run on a new, empty codebase."
void $ Codebase.openNewUcmCodebaseOrExit cbInit tmp
void $ Codebase.openNewUcmCodebaseOrExit cbInit "main.transcript" tmp
pure tmp
runTranscripts'
:: Codebase.Init IO Symbol Ann
:: CodebaseFormat
-> Maybe FilePath
-> FilePath
-> [String]
-> IO Bool
runTranscripts' cbInit mcodepath transcriptDir args = do
runTranscripts' codebaseFormat mcodepath transcriptDir args = do
currentDir <- getCurrentDirectory
case args of
args@(_:_) -> do
@ -275,7 +287,7 @@ runTranscripts' cbInit mcodepath transcriptDir args = do
P.indentN 2 $ P.string err])
Right stanzas -> do
configFilePath <- getConfigFilePath mcodepath
(closeCodebase, theCodebase) <- Codebase.getCodebaseOrExit cbInit $ Just transcriptDir
(closeCodebase, theCodebase) <- getCodebaseOrExit codebaseFormat $ Just transcriptDir
mdOut <- TR.run transcriptDir configFilePath stanzas theCodebase
closeCodebase
let out = currentDir FP.</>
@ -293,17 +305,17 @@ runTranscripts' cbInit mcodepath transcriptDir args = do
pure False
runTranscripts
:: Codebase.Init IO Symbol Ann
:: CodebaseFormat
-> Bool
-> Bool
-> Maybe FilePath
-> [String]
-> IO ()
runTranscripts cbInit inFork keepTemp mcodepath args = do
runTranscripts cbFormat inFork keepTemp mcodepath args = do
progName <- getProgName
transcriptDir <- prepareTranscriptDir cbInit inFork mcodepath
transcriptDir <- prepareTranscriptDir cbFormat inFork mcodepath
completed <-
runTranscripts' cbInit (Just transcriptDir) transcriptDir args
runTranscripts' cbFormat (Just transcriptDir) transcriptDir args
when completed $ do
unless keepTemp $ removeDirectoryRecursive transcriptDir
when keepTemp $ PT.putPrettyLn $
@ -352,3 +364,73 @@ getConfigFilePath mcodepath = (FP.</> ".unisonConfig") <$> Codebase.getCodebaseD
defaultBaseLib :: Maybe RemoteNamespace
defaultBaseLib = rightMay $
runParser VP.defaultBaseLib "version" (Text.pack Version.gitDescribe)
-- | load an existing codebase or exit.
getCodebaseOrExit :: CodebaseFormat -> Maybe Codebase.CodebasePath -> IO (IO (), Codebase.Codebase IO Symbol Ann)
getCodebaseOrExit cbFormat mdir = do
let cbInit = cbInitFor cbFormat
dir <- Codebase.getCodebaseDir mdir
Codebase.openCodebase cbInit "main" dir >>= \case
Left _errRequestedVersion -> do
let
sayNoCodebase = noCodebaseMsg <$> prettyExe <*> prettyDir <*> pure (fmap P.string mdir)
suggestUpgrade = suggestUpgradeMessage <$> prettyExe <*> prettyDir <*> pure (fmap P.string mdir)
prettyExe = P.text . Text.pack <$> getProgName
prettyDir = P.string <$> canonicalizePath dir
PT.putPrettyLn' =<< case cbFormat of
V1 -> sayNoCodebase
V2 -> FC.openCodebase dir >>= \case
Left {} -> sayNoCodebase
Right {} -> suggestUpgrade
Exit.exitFailure
Right x -> pure x
where
noCodebaseMsg :: _
noCodebaseMsg executable prettyDir mdir =
let secondLine =
case mdir of
Just dir ->
"Run `" <> executable <> " -codebase " <> dir
<> " init` to create one, then try again!"
Nothing ->
"Run `" <> executable <> " init` to create one there,"
<> " then try again;"
<> " or `"
<> executable
<> " -codebase <dir>` to load a codebase from someplace else!"
in P.lines
[ "No codebase exists in " <> prettyDir <> ".",
secondLine
]
suggestUpgradeMessage exec resolvedDir specifiedDir =
P.lines
( P.wrap
<$> [ "I looked for a" <> prettyFmt V2 <> " codebase in " <> P.backticked' resolvedDir ","
<> "but found only a"
<> prettyFmt V1
<> "codebase there.",
"",
"You can use:"
]
)
<> P.newline
<> P.bulleted
( P.wrap
<$> [ P.backticked (P.wrap $ exec <> maybe mempty ("-codebase" <>) specifiedDir <> "upgrade-codebase")
<> "to update it to"
<> P.group (prettyFmt V2 <> ","),
P.backticked (P.wrap $ exec <> maybe mempty ("-codebase" <>) specifiedDir <> "init")
<> "to create a new"
<> prettyFmt V2
<> "codebase alongside it, or",
P.backticked (P.wrap $ exec <> "-codebase <dir>")
<> "to load a"
<> prettyFmt V2
<> "codebase from elsewhere."
]
)
prettyFmt :: IsString s => CodebaseFormat -> P.Pretty s
prettyFmt = \case V1 -> "v1"; V2 -> "v2"

2
unison-core/package.yaml
View File

@ -46,4 +46,4 @@ flags:
when:
- condition: flag(optimized)
ghc-options: -funbox-strict-fields
ghc-options: -O2 -funbox-strict-fields

4
unison-core/unison-core1.cabal
View File

@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
-- hash: 25e073d1bb732e90d3e1d3999ec516185669150701345da4fcd35cb20389334d
-- hash: 6eae706c8674f4a7f22bb4bff150798cdaba8aa9186b3d94a6a8467a9cc23d06
name: unison-core1
version: 0.0.0
@ -98,5 +98,5 @@ library
, util
, vector
if flag(optimized)
ghc-options: -funbox-strict-fields
ghc-options: -O2 -funbox-strict-fields
default-language: Haskell2010

2
unison-src/transcripts-using-base/fix2027.output.md
View File

@ -59,7 +59,7 @@ myServer = unsafeRun! '(hello "127.0.0.1" "0")
value:
base.io.Failure.Failure
typeLink base.io.IOFailure "problem" !base.Any.Any
(typeLink base.io.IOFailure) "problem" !base.Any.Any
I'm sorry this message doesn't have more detail about the
location of the failure. My makers plan to fix this in a

6
unison-src/transcripts/bug-strange-closure.output.md
View File

@ -1028,7 +1028,7 @@ rendered = Pretty.get (docFormatConsole doc.guide)
(Left
(SpecialForm.Link
(Left
typeLink Optional))),
(typeLink Optional)))),
!Lit
(Right (Plain "is")),
!Lit (Right (Plain "a")),
@ -1890,7 +1890,7 @@ rendered = Pretty.get (docFormatConsole doc.guide)
(!Lit
(Left
(SpecialForm.Source
[ (Left typeLink Optional,
[ (Left (typeLink Optional),
[]),
(Right
(Term.Term
@ -1922,7 +1922,7 @@ rendered = Pretty.get (docFormatConsole doc.guide)
(!Lit
(Left
(FoldedSource
[ (Left typeLink Optional,
[ (Left (typeLink Optional),
[]),
(Right
(Term.Term