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

This calls for a commit

Browse Source
This commit is contained in:
Runar Bjarnason 2018-11-07 16:38:04 -05:00
parent 108afe9921
commit 849bc0ae3b
14 changed files with 731 additions and 228 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
LICENSE
View File

@ -17,3 +17,7 @@ AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
THE SOFTWARE.
This project bundles Data.Relation, which is available under a
"3-clause BSD" license. See the file deps/relation.

30
deps/relation vendored Normal file
View File

@ -0,0 +1,30 @@
Copyright (c)2010, Leonel Fonseca
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Leonel Fonseca nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

2
parser-typechecker/src/Unison/Builtin.hs
View File

@ -69,7 +69,7 @@ names = Names.fromTermsV builtinTypedTerms
-- <> foldMap DD.effectDeclToNames' builtinEffectDecls
builtinTypedTerms :: Var v => [(v, (Term v, Type v))]
builtinTypedTerms = [(v, (e, t)) | (v, e@(Term.Ann' _ t)) <- builtinTerms ]
builtinTypedTerms = [(v, (e, t)) | (v, (Term.Ann' e t)) <- builtinTerms ]
builtinTerms :: Var v => [(v, Term v)]
builtinTerms =

97
parser-typechecker/src/Unison/Codebase.hs
View File

@ -5,32 +5,40 @@
module Unison.Codebase where
import Data.String (fromString)
import Control.Monad (forM)
import Data.Foldable (toList)
import Data.Maybe (catMaybes)
import Data.List
import qualified Data.Map as Map
import qualified Data.Relation as R
import Data.Set (Set)
import qualified Data.Text as Text
import Text.EditDistance (defaultEditCosts, levenshteinDistance)
import Unison.Codebase.Branch (Branch,Branch0(..))
import qualified Unison.Codebase.Branch as Branch
import qualified Unison.DataDeclaration as DD
import qualified Unison.PrettyPrintEnv as PPE
import Unison.Reference (Reference)
import qualified Unison.Reference as Reference
import qualified Unison.Term as Term
import qualified Unison.TermPrinter as TermPrinter
import qualified Unison.Type as Type
import Unison.Util.PrettyPrint (PrettyPrint)
import qualified Unison.Util.PrettyPrint as PP
import Unison.Util.AnnotatedText (AnnotatedText)
import Unison.Util.ColorText (Color)
import qualified Unison.Var as Var
import qualified Unison.ABT as ABT
import Unison.Names (Names(..), Name)
import Data.String ( fromString )
import Control.Monad ( forM )
import Data.Foldable ( toList, traverse_ )
import Data.Maybe ( catMaybes )
import Data.List
import qualified Data.Map as Map
import Data.Set ( Set )
import qualified Data.Text as Text
import Text.EditDistance ( defaultEditCosts
, levenshteinDistance
)
import qualified Unison.Builtin as Builtin
import Unison.Codebase.Branch ( Branch
, Branch0(..)
)
import qualified Unison.Codebase.Branch as Branch
import qualified Unison.DataDeclaration as DD
import Unison.Parser ( Ann )
import qualified Unison.PrettyPrintEnv as PPE
import Unison.Reference ( Reference )
import qualified Unison.Reference as Reference
import qualified Unison.Term as Term
import qualified Unison.TermPrinter as TermPrinter
import qualified Unison.Type as Type
import Unison.Util.PrettyPrint ( PrettyPrint )
import qualified Unison.Util.PrettyPrint as PP
import Unison.Util.AnnotatedText ( AnnotatedText )
import Unison.Util.ColorText ( Color )
import qualified Unison.Util.Relation as R
import qualified Unison.Var as Var
import qualified Unison.ABT as ABT
import Unison.Names ( Names(..)
, Name
)
type DataDeclaration v a = DD.DataDeclaration' v a
type EffectDeclaration v a = DD.EffectDeclaration' v a
@ -44,8 +52,7 @@ data Codebase m v a =
, putTerm :: Reference.Id -> Term v a -> Type v a -> m ()
, getTypeDeclaration :: Reference.Id -> m (Maybe (Decl v a))
, putTypeDeclaration :: Reference.Id -> Decl v a -> m ()
, putTypeDeclarationImpl :: Reference.Id -> Decl v a -> m ()
, branches :: m [Name]
, getBranch :: Name -> m (Maybe Branch)
-- thought: this merges the given branch with the existing branch
@ -56,6 +63,27 @@ data Codebase m v a =
data Err = InvalidBranchFile FilePath String deriving Show
putTypeDeclaration
:: (Monad m, Ord v) => Codebase m v a -> Reference.Id -> Decl v a -> m ()
putTypeDeclaration c rid decl = do
putTypeDeclarationImpl c rid decl
traverse_ go $ case decl of
Left ed -> DD.effectConstructorTerms rid ed
Right dd -> DD.dataConstructorTerms rid dd
where go (r, tm, typ) = putTerm c r tm typ
-- | Put all the builtins into the codebase
initialize :: (Var.Var v, Monad m) => Codebase m v Ann -> m ()
initialize c = do
traverse_ goData Builtin.builtinDataDecls
traverse_ goEffect Builtin.builtinEffectDecls
where
go f (_, (ref, decl)) = case ref of
Reference.DerivedId id -> putTypeDeclaration c id (f decl)
_ -> pure ()
goEffect = go Left
goData = go Right
prettyBinding :: (Var.Var v, Monad m)
=> Codebase m v a -> Name -> Reference -> Branch -> m (Maybe (PrettyPrint String))
prettyBinding _ _ (Reference.Builtin _) _ = pure Nothing
@ -123,8 +151,17 @@ branchToNames code b = case Branch.head b of
Branch0 {..} -> do
let termRefs = Map.fromList $ R.toList termNamespace
patterns = Map.fromList $ R.toList patternNamespace
types = Map.fromList $ R.toList typeNamespace
types = Map.fromList $ R.toList typeNamespace
terms <- fmap Map.fromList . forM (Map.toList termRefs) $ \(name, ref) -> do
Just typ <- getTypeOfTerm code ref
t <- getTypeOfTerm code ref
typ <- case t of
Just t -> pure t
_ ->
fail
$ "Couldn't look up a type for the term named "
++ show name
++ " with reference "
++ show ref
++ " in the codebase."
pure (name, (Term.ref (ABT.annotation typ) ref, typ))
pure $ Names terms patterns types

91
parser-typechecker/src/Unison/Codebase/Branch.hs
View File

@ -17,15 +17,13 @@ import Data.Foldable
import Data.Functor.Identity (runIdentity)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Relation (Relation)
import qualified Data.Relation as R
import Data.Set (Set)
import qualified Data.Set as Set
--import Control.Monad (join)
import Unison.Codebase.Causal (Causal)
import qualified Unison.Codebase.Causal as Causal
import Unison.Names (Name)
import Unison.Names (Name, Names)
import qualified Unison.Names as Names
import Unison.Codebase.TermEdit (TermEdit, Typing)
import qualified Unison.Codebase.TermEdit as TermEdit
import Unison.Codebase.TypeEdit (TypeEdit)
@ -35,6 +33,8 @@ import Unison.Hashable (Hashable)
import qualified Unison.Hashable as H
import Unison.Reference (Reference)
import qualified Unison.UnisonFile as UF
import Unison.Util.Relation (Relation)
import qualified Unison.Util.Relation as R
import qualified Unison.Term as Term
import qualified Unison.Var as Var
import Unison.Var (Var)
@ -85,6 +85,22 @@ data Branch0 =
data Diff = Diff { ours :: Branch0, theirs :: Branch0 }
fromNames :: Names v a -> Branch0
fromNames names = Branch0 terms pats types R.empty R.empty
where
terms = R.fromList
[ (name, ref)
| (name, (t, _)) <- Map.toList $ Names.termNames names
, ref <- toList $ termToRef t
]
pats = R.fromList . Map.toList $ Names.patternNames names
types = R.fromList . Map.toList $ Names.typeNames names
termToRef r = case r of
Term.Ref' r -> Just r
Term.Request' r id -> Just $ Term.hashRequest r id
Term.Constructor' r id -> Just $ Term.hashConstructor r id
_ -> Nothing
diff :: Branch -> Branch -> Diff
diff ours theirs =
let (ours', theirs') = join bimap (Causal.head . unbranch) (ours, theirs)
@ -149,22 +165,24 @@ hasPatternNamed :: Name -> Branch -> Bool
hasPatternNamed n b = not . null $ patternsNamed n b
termsNamed :: Name -> Branch -> Set Reference
termsNamed name = lookupDom name . termNamespace . Causal.head . unbranch
termsNamed name = R.lookupDom name . termNamespace . Causal.head . unbranch
typesNamed :: Name -> Branch -> Set Reference
typesNamed name = lookupDom name . typeNamespace . Causal.head . unbranch
typesNamed name = R.lookupDom name . typeNamespace . Causal.head . unbranch
patternsNamed :: Name -> Branch -> Set (Reference,Int)
patternsNamed name = lookupDom name . patternNamespace . Causal.head . unbranch
patternsNamed :: Name -> Branch -> Set (Reference, Int)
patternsNamed name =
R.lookupDom name . patternNamespace . Causal.head . unbranch
namesForTerm :: Reference -> Branch -> Set Name
namesForTerm ref = lookupRan ref . termNamespace . Causal.head . unbranch
namesForTerm ref = R.lookupRan ref . termNamespace . Causal.head . unbranch
namesForType :: Reference -> Branch -> Set Name
namesForType ref = lookupRan ref . typeNamespace . Causal.head . unbranch
namesForType ref = R.lookupRan ref . typeNamespace . Causal.head . unbranch
namesForPattern :: Reference -> Int -> Branch -> Set Name
namesForPattern ref cid = lookupRan (ref,cid) . patternNamespace . Causal.head . unbranch
namesForPattern ref cid =
R.lookupRan (ref, cid) . patternNamespace . Causal.head . unbranch
prettyPrintEnv1 :: Branch -> PrettyPrintEnv
prettyPrintEnv1 b = PrettyPrintEnv terms ctors patterns types where
@ -189,7 +207,7 @@ conflicts f = conflicts' . f . Causal.head . unbranch where
-- build a map of those sets
foldl' go Map.empty (R.dom r) where
go m a =
let bs = lookupDom a r
let bs = R.lookupDom a r
in if Set.size bs > 1 then Map.insert a bs m else m
-- Use as `resolved editedTerms branch`
@ -198,7 +216,7 @@ resolved f = resolved' . f . Causal.head . unbranch where
resolved' :: Ord a => Relation a b -> Map a b
resolved' r = foldl' go Map.empty (R.dom r) where
go m a =
let bs = lookupDom a r
let bs = R.lookupDom a r
in if Set.size bs == 1 then Map.insert a (Set.findMin bs) m else m
@ -401,45 +419,18 @@ insertNames :: Monad m
-> Reference -> m (Relation Reference Name)
insertNames ops m r = foldl' (flip $ R.insert r) m <$> name ops r
insertManyRan :: (Foldable f, Ord a, Ord b)
=> a -> f b -> Relation a b -> Relation a b
insertManyRan a bs r = foldl' (flip $ R.insert a) r bs
insertManyDom :: (Foldable f, Ord a, Ord b)
=> f a -> b -> Relation a b -> Relation a b
insertManyDom as b r = foldl' (flip $ flip R.insert b) r as
lookupRan :: Ord b => b -> Relation a b -> Set a
lookupRan b r = fromMaybe Set.empty $ R.lookupRan b r
lookupDom :: Ord a => a -> Relation a b -> Set b
lookupDom a r = fromMaybe Set.empty $ R.lookupDom a r
replaceDom :: (Ord a, Ord b) => a -> a -> Relation a b -> Relation a b
replaceDom a a' r =
foldl' (\r b -> R.insert a' b $ R.delete a b r) r (lookupDom a r)
-- Todo: fork the relation library
replaceRan :: (Ord a, Ord b) => b -> b -> Relation a b -> Relation a b
replaceRan b b' r =
foldl' (\r a -> R.insert a b' $ R.delete a b r) r (lookupRan b r)
deleteRan :: (Ord a, Ord b) => b -> Relation a b -> Relation a b
deleteRan b r = foldl' (\r a -> R.delete a b r) r $ lookupRan b r
deleteDom :: (Ord a, Ord b) => a -> Relation a b -> Relation a b
deleteDom a r = foldl' (\r b -> R.delete a b r) r $ lookupDom a r
replaceTerm :: Reference -> Reference -> Typing -> Branch -> Branch
replaceTerm old new typ (Branch b) = Branch $ Causal.step go b where
edit = TermEdit.Replace new typ
go b = b { editedTerms = R.insert old edit (editedTerms b)
, termNamespace = replaceRan old new $ termNamespace b
, termNamespace = R.replaceRan old new $ termNamespace b
}
-- If any `as` aren't in `b`, then delete them from `c` as well. Kind of sad.
deleteOrphans :: (Ord a, Ord c) => Set a -> Relation a b -> Relation a c -> Relation a c
deleteOrphans as b c = foldl' (\c a -> if R.memberDom a b then c else deleteDom a c) c as
deleteOrphans
:: (Ord a, Ord c) => Set a -> Relation a b -> Relation a c -> Relation a c
deleteOrphans as b c =
foldl' (\c a -> if R.memberDom a b then c else R.deleteDom a c) c as
codebase :: Monad m => ReferenceOps m -> Branch -> m (Set Reference)
codebase ops (Branch (Causal.head -> Branch0 {..})) =
@ -475,14 +466,14 @@ transitiveClosure1' f a = runIdentity $ transitiveClosure1 (pure.f) a
deprecateTerm :: Reference -> Branch -> Branch
deprecateTerm old (Branch b) = Branch $ Causal.step go b where
go b = b { editedTerms = R.insert old TermEdit.Deprecate (editedTerms b)
, termNamespace = deleteRan old (termNamespace b)
, termNamespace = R.deleteRan old (termNamespace b)
}
deprecateType :: Reference -> Branch -> Branch
deprecateType old (Branch b) = Branch $ Causal.step go b where
go b = b { editedTypes = R.insert old TypeEdit.Deprecate (editedTypes b)
, typeNamespace = deleteRan old (typeNamespace b)
, typeNamespace = R.deleteRan old (typeNamespace b)
}
instance (Hashable a, Hashable b) => Hashable (Relation a b) where
@ -494,7 +485,7 @@ instance Hashable Branch0 where
H.tokens editedTerms ++ H.tokens editedTypes
resolveTerm :: Name -> Branch -> Set Reference
resolveTerm n (Branch (Causal.head -> b)) = lookupDom n (termNamespace b)
resolveTerm n (Branch (Causal.head -> b)) = R.lookupDom n (termNamespace b)
resolveTermUniquely :: Name -> Branch -> Maybe Reference
resolveTermUniquely n b =
@ -526,12 +517,12 @@ termOrTypeOp ops r ifTerm ifType = do
renameType :: Name -> Name -> Branch -> Branch
renameType old new (Branch b) =
Branch $ Causal.stepIf (R.memberDom old . typeNamespace) go b where
go b = b { typeNamespace = replaceDom old new (typeNamespace b)}
go b = b { typeNamespace = R.replaceDom old new (typeNamespace b)}
renameTerm :: Name -> Name -> Branch -> Branch
renameTerm old new (Branch b) =
Branch $ Causal.stepIf (R.memberDom old . termNamespace) go b where
go b = b { termNamespace = replaceDom old new (termNamespace b)}
go b = b { termNamespace = R.replaceDom old new (termNamespace b)}
toHash :: Branch -> Hash
toHash = Causal.currentHash . unbranch

174
parser-typechecker/src/Unison/Codebase/CommandLine.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE LambdaCase #-}
@ -5,60 +6,82 @@
module Unison.Codebase.CommandLine (main) where
import Data.Bifunctor (second)
import System.Random (randomRIO)
import Control.Concurrent (forkIO)
import Control.Exception (catch, finally)
import Control.Monad (forM_, forever, liftM2,
void, when)
import Control.Monad.STM (STM, atomically)
import qualified Data.Char as Char
import Data.Foldable (toList, traverse_)
import Data.IORef (IORef, newIORef, writeIORef, readIORef)
import Data.List (find, isSuffixOf, isPrefixOf,
sort)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.String (fromString)
import Data.Strings (strPadLeft)
import Data.Text (Text, pack, unpack)
import Data.Bifunctor ( second )
import System.Random ( randomRIO )
import Control.Concurrent ( forkIO )
import Control.Exception ( catch
, finally
)
import Control.Monad ( forM_
, forever
, liftM2
, void
, when
)
import Control.Monad.STM ( STM
, atomically
)
import qualified Data.Char as Char
import Data.Foldable ( toList
, traverse_
)
import Data.IORef ( IORef
, newIORef
, writeIORef
, readIORef
)
import Data.List ( find
, isSuffixOf
, isPrefixOf
, sort
)
import Data.Set ( Set )
import qualified Data.Set as Set
import Data.String ( fromString )
import Data.Strings ( strPadLeft )
import Data.Text ( Text
, pack
, unpack
)
import qualified Data.Text.IO
import qualified System.Console.ANSI as Console
import System.FilePath (FilePath)
import qualified Text.Read as Read
import qualified Unison.Reference as Reference
import System.IO.Error (isEOFError)
import qualified Unison.Builtin as B
import Unison.Codebase (Codebase)
import qualified Unison.Codebase as Codebase
import Unison.Codebase.Branch (Branch)
import qualified Unison.Codebase.Branch as Branch
import Unison.Names (Name)
import Unison.Codebase.Runtime (Runtime)
import qualified Unison.Codebase.Runtime as RT
import qualified Unison.Codebase.Watch as Watch
import Unison.FileParsers (parseAndSynthesizeFile)
import qualified Unison.Parser as Parser
import qualified Unison.PrintError as PrintError
import Unison.PrintError (prettyParseError,
prettyTypecheckedFile,
renderNoteAsANSI)
import Unison.Result (pattern Result)
import qualified Unison.Result as Result
import qualified Unison.UnisonFile as UF
import qualified Unison.Util.ColorText as Color
import qualified Unison.Util.Menu as Menu
import qualified System.Console.ANSI as Console
import System.FilePath ( FilePath )
import qualified Text.Read as Read
import qualified Unison.Reference as Reference
import System.IO.Error ( isEOFError )
import qualified Unison.Builtin as B
import Unison.Codebase ( Codebase )
import qualified Unison.Codebase as Codebase
import Unison.Codebase.Branch ( Branch )
import qualified Unison.Codebase.Branch as Branch
import Unison.Names ( Name )
import Unison.Codebase.Runtime ( Runtime )
import qualified Unison.Codebase.Runtime as RT
import qualified Unison.Codebase.Watch as Watch
import Unison.FileParsers ( parseAndSynthesizeFile )
import qualified Unison.Parser as Parser
import qualified Unison.PrintError as PrintError
import Unison.PrintError ( prettyParseError
, prettyTypecheckedFile
, renderNoteAsANSI
)
import Unison.Result ( pattern Result )
import qualified Unison.Result as Result
import Unison.Symbol ( Symbol )
import qualified Unison.UnisonFile as UF
import qualified Unison.Util.ColorText as Color
import qualified Unison.Util.Menu as Menu
import Unison.Util.Monoid
import qualified Unison.Util.PrettyPrint as PP
import Unison.Util.TQueue (TQueue)
import qualified Unison.Util.TQueue as TQueue
import Unison.Var (Var)
import qualified Unison.Var as Var
import qualified Data.Map as Map
import Unison.Parser (Ann)
import qualified Data.Text as Text
import Unison.Names (Names)
import qualified Unison.Term as Term
import qualified Unison.Util.PrettyPrint as PP
import Unison.Util.TQueue ( TQueue )
import qualified Unison.Util.TQueue as TQueue
import Unison.Var ( Var )
import qualified Unison.Var as Var
import qualified Data.Map as Map
import Unison.Parser ( Ann )
import qualified Data.Text as Text
import Unison.Names ( Names )
import qualified Unison.Term as Term
data Event
= UnisonFileChanged FilePath Text
@ -266,7 +289,8 @@ main dir currentBranchName initialFile startRuntime codebase = do
"\nUse the `> edit` command to have these definitions replace the existing ones."
go branch name
else do
-- todo: this should probably just be a function in Codebase, something like
-- todo: this should probably just be a function in Codebase,
-- something like
-- addFile :: Codebase -> TypecheckedUnisonFile -> m ()
let hashedTerms = UF.hashTerms typecheckedFile
putStrLn $ "Adding the following definitions:"
@ -486,34 +510,40 @@ mergeBranchAndShowDiff codebase targetName sourceBranch = do
foo :: Text -> (String, Text)
foo name = (unpack name, name)
selectBranch :: Codebase IO v a -> Name -> IO String -> IO (Maybe (Name, Branch))
selectBranch
:: Codebase IO v a -> Name -> IO String -> IO (Maybe (Name, Branch))
selectBranch codebase name takeLine = do
let branchMenu caption branches =
Menu.menu1
takeLine -- console
caption -- caption
(fromString . unpack) -- render
(fromString . fmap Char.toLower . show) -- renderMeta
(foo <$> branches) -- groups
[("create", Create), ("cancel", Cancel)] -- metas
Nothing -- initial
let branchMenu caption branches = Menu.menu1
takeLine -- console
caption -- caption
(fromString . unpack) -- render
(fromString . fmap Char.toLower . show) -- renderMeta
(foo <$> branches) -- groups
[("create", Create), ("cancel", Cancel)] -- metas
Nothing -- initial
branch <- Codebase.getBranch codebase name
case branch of
-- if branch named `name` exists, load it,
Just branch -> pure . Just $ (name, branch)
-- otherwise,
-- list branches that do exist, plus option to create, plus option to cancel
Nothing -> do
let caption = fromString $
"The branch " ++ show name ++ " doesn't exist. " ++
"Do you want to create it, or pick a different one?"
-- list branches that do exist, plus option to create, plus option to cancel
Nothing -> do
let caption =
fromString
$ "The branch "
++ show name
++ " doesn't exist. "
++ "Do you want to create it, or pick a different one?"
branches <- Codebase.branches codebase
choice <- branchMenu caption branches
choice <- branchMenu caption branches
case choice of
Just (Left Cancel) -> pure Nothing
Just (Left Create) -> do
branch <- mergeBranchAndShowDiff codebase name mempty
branch <- mergeBranchAndShowDiff codebase name builtinBranch
pure $ Just (name, branch)
Just (Right name) -> selectBranch codebase name takeLine
Nothing -> pure Nothing
Nothing -> pure Nothing
builtinBranch :: Branch
builtinBranch = Branch.append (Branch.fromNames $ B.names @Symbol) mempty

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

@ -109,6 +109,7 @@ addComponentId i n s = show i <> "-" <> show n <> "-" <> s
branchesPath :: FilePath -> FilePath
branchesPath path = path </> "branches"
branchPath :: FilePath -> Text -> FilePath
branchPath path name = branchesPath path </> Text.unpack name

3
parser-typechecker/src/Unison/Codebase/Serialization.hs
View File

@ -8,7 +8,6 @@ import Data.ByteString (ByteString, readFile, writeFile)
import System.Directory (doesFileExist, createDirectoryIfMissing)
import System.FilePath (takeDirectory)
import Prelude hiding (readFile, writeFile)
import Debug.Trace
type Get a = forall m . MonadGet m => m a
type Put a = forall m . MonadPut m => a -> m ()
@ -25,7 +24,7 @@ getFromBytes getA bytes =
getFromFile :: Get a -> FilePath -> IO (Maybe a)
getFromFile getA file = do
b <- doesFileExist file
if (traceShow ("getFromFile", file, b) b) then getFromBytes getA <$> readFile file else pure Nothing
if b then getFromBytes getA <$> readFile file else pure Nothing
putBytes :: Put a -> a -> ByteString
putBytes put a = runPutS (put a)

98
parser-typechecker/src/Unison/Codebase/Serialization/V0.hs
View File

@ -3,49 +3,63 @@
module Unison.Codebase.Serialization.V0 where
-- import qualified Data.Text as Text
import qualified Data.Vector as Vector
import qualified Unison.PatternP as Pattern
import Unison.PatternP (Pattern)
import Control.Applicative (liftA2,liftA3)
import Control.Monad (replicateM)
import Data.Bits (Bits)
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial (serialize, deserialize, serializeBE, deserializeBE)
import Data.Bytes.Signed (Unsigned)
import Data.Bytes.VarInt (VarInt(..))
import Data.Foldable (traverse_)
import Data.Int (Int64)
import Data.List (elemIndex, foldl')
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.Relation (Relation)
import Data.Word (Word64)
import Unison.Codebase.Branch (Branch(..), Branch0(..))
import Unison.Codebase.Causal (Causal)
import Unison.Codebase.TermEdit (TermEdit)
import Unison.Codebase.TypeEdit (TypeEdit)
import Unison.Hash (Hash)
import Unison.Kind (Kind)
import Unison.Reference (Reference)
import Unison.Symbol (Symbol(..))
import Unison.Term (AnnotatedTerm)
import qualified Data.ByteString as B
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Unison.ABT as ABT
import qualified Unison.Codebase.Causal as Causal
import qualified Unison.Codebase.TermEdit as TermEdit
import qualified Unison.Codebase.TypeEdit as TypeEdit
import qualified Data.Vector as Vector
import qualified Unison.PatternP as Pattern
import Unison.PatternP ( Pattern )
import Control.Applicative ( liftA2
, liftA3
)
import Control.Monad ( replicateM )
import Data.Bits ( Bits )
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial ( serialize
, deserialize
, serializeBE
, deserializeBE
)
import Data.Bytes.Signed ( Unsigned )
import Data.Bytes.VarInt ( VarInt(..) )
import Data.Foldable ( traverse_ )
import Data.Int ( Int64 )
import Data.List ( elemIndex
, foldl'
)
import Data.Text ( Text )
import Data.Text.Encoding ( encodeUtf8
, decodeUtf8
)
import Data.Word ( Word64 )
import Unison.Codebase.Branch ( Branch(..)
, Branch0(..)
)
import Unison.Codebase.Causal ( Causal )
import Unison.Codebase.TermEdit ( TermEdit )
import Unison.Codebase.TypeEdit ( TypeEdit )
import Unison.Hash ( Hash )
import Unison.Kind ( Kind )
import Unison.Reference ( Reference )
import Unison.Symbol ( Symbol(..) )
import Unison.Term ( AnnotatedTerm )
import qualified Data.ByteString as B
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Unison.ABT as ABT
import qualified Unison.Codebase.Causal as Causal
import qualified Unison.Codebase.TermEdit as TermEdit
import qualified Unison.Codebase.TypeEdit as TypeEdit
import qualified Unison.Codebase.Serialization as S
import qualified Unison.Hash as Hash
import qualified Unison.Kind as Kind
import qualified Unison.Reference as Reference
import qualified Data.Relation as Relation
import qualified Unison.Term as Term
import qualified Unison.Type as Type
import qualified Unison.DataDeclaration as DataDeclaration
import Unison.DataDeclaration (DataDeclaration', EffectDeclaration')
import qualified Unison.Hash as Hash
import qualified Unison.Kind as Kind
import qualified Unison.Reference as Reference
import qualified Unison.Term as Term
import qualified Unison.Type as Type
import Unison.Util.Relation ( Relation )
import qualified Unison.Util.Relation as Relation
import qualified Unison.DataDeclaration as DataDeclaration
import Unison.DataDeclaration ( DataDeclaration'
, EffectDeclaration'
)
-- ABOUT THIS FORMAT:
--

39
parser-typechecker/src/Unison/DataDeclaration.hs
View File

@ -38,6 +38,45 @@ data DataDeclaration' v a = DataDeclaration {
constructors' :: [(a, v, AnnotatedType v a)]
} deriving (Show, Functor)
generateConstructorRefs
:: (Reference -> Int -> Reference)
-> Reference.Id
-> Int
-> [(Int, Reference)]
generateConstructorRefs hashCtor rid n =
(\i -> (i, hashCtor (Reference.DerivedPrivate_ rid) i)) <$> [0 .. n]
-- Returns references to the constructors,
-- along with the terms for those references and their types.
constructorTerms
:: (Reference -> Int -> Reference)
-> (a -> Reference -> Int -> AnnotatedTerm v a)
-> Reference.Id
-> DataDeclaration' v a
-> [(Reference.Id, AnnotatedTerm v a, AnnotatedType v a)]
constructorTerms hashCtor f rid dd =
(\((a, _, t), (i, re@(Reference.DerivedId r))) -> (r, f a re i, t)) <$> zip
(constructors' dd)
(generateConstructorRefs hashCtor rid (length $ constructors dd))
dataConstructorTerms
:: Ord v
=> Reference.Id
-> DataDeclaration' v a
-> [(Reference.Id, AnnotatedTerm v a, AnnotatedType v a)]
dataConstructorTerms = constructorTerms Term.hashConstructor Term.constructor
effectConstructorTerms
:: Ord v
=> Reference.Id
-> EffectDeclaration' v a
-> [(Reference.Id, AnnotatedTerm v a, AnnotatedType v a)]
effectConstructorTerms rid ed =
constructorTerms Term.hashRequest Term.request rid $ toDataDecl ed
constructorTypes :: DataDeclaration' v a -> [AnnotatedType v a]
constructorTypes = (snd <$>) . constructors
constructors :: DataDeclaration' v a -> [(v, AnnotatedType v a)]
constructors (DataDeclaration _ _ ctors) = [(v,t) | (_,v,t) <- ctors ]

22
parser-typechecker/src/Unison/Term.hs
View File

@ -601,14 +601,22 @@ hashComponents :: Var v => Map v (AnnotatedTerm v a) -> Map v (Reference, Annota
hashComponents m = Reference.hashComponents (\r -> ref() r) m
-- The hash for a constructor
hashConstructor'
:: (Reference -> Int -> Term Symbol) -> Reference -> Int -> Reference
hashConstructor' f r cid =
let
-- this is a bit circuitous, but defining everything in terms of hashComponents
-- ensure the hashing is always done in the same way
m = hashComponents (Map.fromList [(Var.named "_" :: Symbol, f r cid)])
in case toList m of
[(r, _)] -> r
_ -> error "unpossible"
hashConstructor :: Reference -> Int -> Reference
hashConstructor r cid = let
-- this is a bit circuitous, but defining everything in terms of hashComponents
-- ensure the hashing is always done in the same way
m = hashComponents (Map.fromList [(Var.named "_" :: Symbol, constructor() r cid)])
in case toList m of
[(r,_)] -> r
_ -> error "unpossible"
hashConstructor = hashConstructor' $ constructor ()
hashRequest :: Reference -> Int -> Reference
hashRequest = hashConstructor' $ request ()
anf :: ∀ vt at v a . (Semigroup a, Var v)
=> AnnotatedTerm2 vt at a v a -> AnnotatedTerm2 vt at a v a

339
parser-typechecker/src/Unison/Util/Relation.hs Normal file
View File

@ -0,0 +1,339 @@
module Unison.Util.Relation where
import Prelude hiding ( null )
import Data.Foldable ( foldl' )
import qualified Data.Map as M
import Data.Set ( Set )
import qualified Data.Set as S
import Data.Maybe ( isJust
, fromMaybe
)
import Data.Map ( Map )
import qualified Data.Map as Map
-- |
-- This implementation avoids using @"Set (a,b)"@ because
-- it it is necessary to search for an item without knowing both @D@ and @R@.
--
-- In "Set", you must know both values to search.
--
-- Thus, we have are two maps to updated together.
--
-- 1. Always be careful with the associated set of the key.
--
-- 2. If you union two relations, apply union to the set of values.
--
-- 3. If you subtract, take care when handling the set of values.
--
-- As a multi-map, each key is asscoated with a Set of values v.
--
-- We do not allow the associations with the 'empty' Set.
--
data Relation a b = Relation { domain :: M.Map a (Set b)
, range :: M.Map b (Set a)
}
deriving (Show, Eq, Ord)
-- * Functions about relations
-- The size is calculated using the domain.
-- | @size r@ returns the number of tuples in the relation.
size :: Relation a b -> Int
size r = M.foldr' ((+) . S.size) 0 (domain r)
-- | Construct a relation with no elements.
empty :: Relation a b
empty = Relation M.empty M.empty
-- |
-- The list must be formatted like: [(k1, v1), (k2, v2),..,(kn, vn)].
fromList :: (Ord a, Ord b) => [(a, b)] -> Relation a b
fromList xs = Relation
{ domain = M.fromListWith S.union $ snd2Set xs
, range = M.fromListWith S.union $ flipAndSet xs
}
where
snd2Set = map (\(x, y) -> (x, S.singleton y))
flipAndSet = map (\(x, y) -> (y, S.singleton x))
-- |
-- Builds a List from a Relation.
toList :: Relation a b -> [(a, b)]
toList r =
concatMap (\(x, y) -> zip (repeat x) (S.toList y)) (M.toList . domain $ r)
-- |
-- Builds a 'Relation' consiting of an association between: @x@ and @y@.
singleton :: a -> b -> Relation a b
singleton x y = Relation
{ domain = M.singleton x (S.singleton y)
, range = M.singleton y (S.singleton x)
}
-- | The 'Relation' that results from the union of two relations: @r@ and @s@.
union :: (Ord a, Ord b) => Relation a b -> Relation a b -> Relation a b
union r s = Relation
{ domain = M.unionWith S.union (domain r) (domain s)
, range = M.unionWith S.union (range r) (range s)
}
---------------------------------------------------------------
-- |
-- This fragment provided by:
--
-- @
-- \ Module : Data.Map
-- \ Copyright : (c) Daan Leijen 2002
-- \ (c) Andriy Palamarchuk 2008
-- \ License : BSD-style
-- \ Maintainer : libraries\@haskell.org
-- \ Stability : provisional
-- \ Portability : portable
-- @
--
--
foldlStrict :: (a -> b -> a) -> a -> [b] -> a
foldlStrict f z xs = case xs of
[] -> z
(x : xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
---------------------------------------------------------------
-- | Union a list of relations using the 'empty' relation.
unions :: (Ord a, Ord b) => [Relation a b] -> Relation a b
unions = foldlStrict union empty
-- | Insert a relation @ x @ and @ y @ in the relation @ r @
insert :: (Ord a, Ord b) => a -> b -> Relation a b -> Relation a b
insert x y r = -- r { domain = domain', range = range' }
Relation domain' range'
where
domain' = M.insertWith S.union x (S.singleton y) (domain r)
range' = M.insertWith S.union y (S.singleton x) (range r)
-- $deletenotes
--
-- The deletion is not difficult but is delicate:
--
-- @
-- r = { domain { (k1, {v1a, v3})
-- , (k2, {v2a})
-- , (k3, {v3b, v3})
-- }
-- , range { (v1a, {k1}
-- , (v2a, {k2{
-- , (v3 , {k1, k3}
-- , (v3b, {k3}
-- }
-- }
-- @
--
-- To delete (k,v) in the relation do:
-- 1. Working with the domain:
-- 1a. Delete v from the Set VS associated with k.
-- 1b. If VS is empty, delete k in the domain.
-- 2. Working in the range:
-- 2a. Delete k from the Set VS associated with v.
-- 2b. If VS is empty, delete v in the range.
--
--
-- | Delete an association in the relation.
delete :: (Ord a, Ord b) => a -> b -> Relation a b -> Relation a b
delete x y r = r { domain = domain', range = range' }
where
domain' = M.update (erase y) x (domain r)
range' = M.update (erase x) y (range r)
erase e s = if S.singleton e == s then Nothing else Just $ S.delete e s
-- | The Set of values associated with a value in the domain.
lookupDom' :: Ord a => a -> Relation a b -> Maybe (Set b)
lookupDom' x r = M.lookup x (domain r)
-- | The Set of values associated with a value in the range.
lookupRan' :: Ord b => b -> Relation a b -> Maybe (Set a)
lookupRan' y r = M.lookup y (range r)
-- | True if the element @ x @ exists in the domain of @ r @.
memberDom :: Ord a => a -> Relation a b -> Bool
memberDom x r = isJust $ lookupDom' x r
-- | True if the element exists in the range.
memberRan :: Ord b => b -> Relation a b -> Bool
memberRan y r = isJust $ lookupRan' y r
-- |
-- True if the relation @r@ is the 'empty' relation.
null :: Relation a b -> Bool
null r = M.null $ domain r
-- Before 2010/11/09 null::Ord b => Relation a b -> Bool
-- | True if the relation contains the association @x@ and @y@
member :: (Ord a, Ord b) => a -> b -> Relation a b -> Bool
member x y r = case lookupDom' x r of
Just s -> S.member y s
Nothing -> False
-- | True if the relation /does not/ contain the association @x@ and @y@
notMember :: (Ord a, Ord b) => a -> b -> Relation a b -> Bool
notMember x y r = not $ member x y r
-- | Returns the domain in the relation, as a Set, in its entirety.
dom :: Relation a b -> Set a
dom r = M.keysSet (domain r)
-- | Returns the range of the relation, as a Set, in its entirety.
ran :: Relation a b -> Set b
ran r = M.keysSet (range r)
-- |
-- A compact set of sets the values of which can be @Just (Set x)@ or @Nothing@.
--
-- The cases of 'Nothing' are purged.
--
-- It is similar to 'concat'.
compactSet :: Ord a => Set (Maybe (Set a)) -> Set a
compactSet = S.fold (S.union . fromMaybe S.empty) S.empty
-- $selectops
--
-- Primitive implementation for the /right selection/ and /left selection/ operators.
--
-- PICA provides both operators:
-- '|>' and '<|'
-- and '|$>' and '<$|'
--
-- in this library, for working with Relations and OIS (Ordered, Inductive Sets?).
--
-- PICA exposes the operators defined here, so as not to interfere with the abstraction
-- of the Relation type and because having access to Relation hidden components is a more
-- efficient implementation of the operation of restriction.
--
-- @
-- (a <$| b) r
--
-- denotes: for every element @b@ from the Set @B@,
-- select an element @a@ from the Set @A@ ,
-- if @a@
-- is related to @b@
-- in @r@
-- @
--
-- @
-- (a |$> b) r
--
-- denotes: for every element @a@ from the Set @A@ ,
-- select an element @b@ from the Set @B@,
-- if @a@
-- is related to @b@
-- in @r@
-- @
--
-- With regard to domain restriction and range restriction operators
-- of the language, those are described differently and return the domain or the range.
-- |
-- @(Case b <| r a)@
--
(<$|) :: (Ord a, Ord b) => Set a -> Set b -> Relation a b -> Set a
(as <$| bs) r = as `S.intersection` generarAS bs
where generarAS = compactSet . S.map (`lookupRan'` r)
-- The subsets of the domain (a) associated with each @b@
-- such that @b@ in @B@ and (b) are in the range of the relation.
-- The expression 'S.map' returns a set of @Either (Set a)@.
-- |
-- @( Case a |> r b )@
(|$>) :: (Ord a, Ord b) => Set a -> Set b -> Relation a b -> Set b
(as |$> bs) r = bs `S.intersection` generarBS as
where generarBS = compactSet . S.map (`lookupDom'` r)
-- | Domain restriction for a relation. Modeled on z.
(<|) :: (Ord a, Ord b) => Set a -> Relation a b -> Relation a b
s <| r = fromList
$ concatMap (\(x, y) -> zip (repeat x) (S.toList y)) (M.toList domain')
where
domain' = M.unions . map filtrar . S.toList $ s
filtrar x = M.filterWithKey (\k _ -> k == x) dr
dr = domain r -- just to memoize the value
-- | Range restriction for a relation. Modeled on z.
(|>) :: (Ord a, Ord b) => Relation a b -> Set b -> Relation a b
r |> t = fromList
$ concatMap (\(x, y) -> zip (S.toList y) (repeat x)) (M.toList range')
where
range' = M.unions . map filtrar . S.toList $ t
filtrar x = M.filterWithKey (\k _ -> k == x) rr
rr = range r -- just to memoize the value
-- Note:
--
-- As you have seen this implementation is expensive in terms
-- of storage. Information is registered twice.
-- For the operators |> and <| we follow a pattern used in
-- the @fromList@ constructor and @toList@ flattener:
-- It is enough to know one half of the Relation (the domain or
-- the range) to create to other half.
--
--
insertManyRan
:: (Foldable f, Ord a, Ord b) => a -> f b -> Relation a b -> Relation a b
insertManyRan a bs r = foldl' (flip $ insert a) r bs
insertManyDom
:: (Foldable f, Ord a, Ord b) => f a -> b -> Relation a b -> Relation a b
insertManyDom as b r = foldl' (flip $ flip insert b) r as
lookupRan :: Ord b => b -> Relation a b -> Set a
lookupRan b r = fromMaybe S.empty $ lookupRan' b r
lookupDom :: Ord a => a -> Relation a b -> Set b
lookupDom a r = fromMaybe S.empty $ lookupDom' a r
replaceDom :: (Ord a, Ord b) => a -> a -> Relation a b -> Relation a b
replaceDom a a' r =
foldl' (\r b -> insert a' b $ delete a b r) r (lookupDom a r)
-- Todo: fork the relation library
replaceRan :: (Ord a, Ord b) => b -> b -> Relation a b -> Relation a b
replaceRan b b' r =
foldl' (\r a -> insert a b' $ delete a b r) r (lookupRan b r)
deleteRan :: (Ord a, Ord b) => b -> Relation a b -> Relation a b
deleteRan b r = foldl' (\r a -> delete a b r) r $ lookupRan b r
deleteDom :: (Ord a, Ord b) => a -> Relation a b -> Relation a b
deleteDom a r = foldl' (\r b -> delete a b r) r $ lookupDom a r
fromMap :: (Ord a, Ord b) => Map a b -> Relation a b
fromMap = fromList . Map.toList

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

@ -94,6 +94,7 @@ library
Unison.Util.Monoid
Unison.Util.PrettyPrint
Unison.Util.Range
Unison.Util.Relation
Unison.Util.TQueue
Unison.Var
@ -127,7 +128,6 @@ library
megaparsec,
prelude-extras,
random,
relation,
safe,
stm,
strings,

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

@ -3,40 +3,51 @@
module Main where
import Data.Char (toLower)
import Safe (headMay)
import System.Environment (getArgs)
import System.IO (BufferMode (NoBuffering),
hSetBuffering, stdout)
import qualified Unison.Codebase.CommandLine as CommandLine
import qualified Unison.Codebase.FileCodebase as FileCodebase
import Unison.Codebase.Runtime.JVM (javaRuntime)
import qualified Unison.Codebase.Serialization as S
import Unison.Codebase.Serialization.V0 (formatSymbol, getSymbol)
import Unison.Parser (Ann (External))
import Data.Char ( toLower )
import Safe ( headMay )
import System.Environment ( getArgs )
import System.IO ( BufferMode(NoBuffering)
, hSetBuffering
, stdout
)
import qualified Unison.Codebase as Codebase
import qualified Unison.Codebase.CommandLine as CommandLine
import qualified Unison.Codebase.FileCodebase as FileCodebase
import Unison.Codebase.Runtime.JVM ( javaRuntime )
import qualified Unison.Codebase.Serialization as S
import Unison.Codebase.Serialization.V0
( formatSymbol
, getSymbol
)
import Unison.Parser ( Ann(External) )
main :: IO ()
main = do
args <- getArgs
hSetBuffering stdout NoBuffering -- cool
let codebasePath = ".unison"
let codebasePath = ".unison"
initialBranchName = "master"
scratchFilePath = "."
launch = CommandLine.main scratchFilePath initialBranchName
(headMay args)
(javaRuntime getSymbol 42441)
(FileCodebase.codebase1 External formatSymbol formatAnn codebasePath)
scratchFilePath = "."
theCodebase =
FileCodebase.codebase1 External formatSymbol formatAnn codebasePath
launch = CommandLine.main scratchFilePath
initialBranchName
(headMay args)
(javaRuntime getSymbol 42441)
theCodebase
exists <- FileCodebase.exists codebasePath
case exists of
True -> launch
True -> launch
False -> do
putStr "I can't find a Unison codebase here, would you like to create one? [y/n] "
putStr
"I can't find a Unison codebase here, would you like to create one? [y/n] "
line <- getLine
case words (map toLower line) of
('y':_):_ -> FileCodebase.initialize codebasePath *> launch
_ -> pure ()
('y' : _) : _ -> do
FileCodebase.initialize codebasePath
Codebase.initialize theCodebase
launch
_ -> pure ()
formatAnn :: S.Format Ann
formatAnn = S.Format (pure External) (\_ -> pure ())