mirror of
https://github.com/unisonweb/unison.git
synced 2024-10-26 11:07:48 +03:00
This calls for a commit
This commit is contained in:
parent
108afe9921
commit
849bc0ae3b
4
LICENSE
4
LICENSE
@ -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
30
deps/relation
vendored
Normal 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.
|
@ -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 =
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
@ -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)
|
||||
|
@ -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:
|
||||
--
|
||||
|
@ -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 ]
|
||||
|
||||
|
@ -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
339
parser-typechecker/src/Unison/Util/Relation.hs
Normal 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
|
@ -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,
|
||||
|
@ -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 ())
|
||||
|
Loading…
Reference in New Issue
Block a user