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, 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 OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
THE SOFTWARE. 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 -- <> foldMap DD.effectDeclToNames' builtinEffectDecls
builtinTypedTerms :: Var v => [(v, (Term v, Type v))] 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 :: Var v => [(v, Term v)]
builtinTerms = builtinTerms =

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

@ -5,32 +5,40 @@
module Unison.Codebase where module Unison.Codebase where
import Data.String (fromString) import Data.String ( fromString )
import Control.Monad (forM) import Control.Monad ( forM )
import Data.Foldable (toList) import Data.Foldable ( toList, traverse_ )
import Data.Maybe (catMaybes) import Data.Maybe ( catMaybes )
import Data.List import Data.List
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Relation as R import Data.Set ( Set )
import Data.Set (Set) import qualified Data.Text as Text
import qualified Data.Text as Text import Text.EditDistance ( defaultEditCosts
import Text.EditDistance (defaultEditCosts, levenshteinDistance) , levenshteinDistance
import Unison.Codebase.Branch (Branch,Branch0(..)) )
import qualified Unison.Codebase.Branch as Branch import qualified Unison.Builtin as Builtin
import qualified Unison.DataDeclaration as DD import Unison.Codebase.Branch ( Branch
import qualified Unison.PrettyPrintEnv as PPE , Branch0(..)
import Unison.Reference (Reference) )
import qualified Unison.Reference as Reference import qualified Unison.Codebase.Branch as Branch
import qualified Unison.Term as Term import qualified Unison.DataDeclaration as DD
import qualified Unison.TermPrinter as TermPrinter import Unison.Parser ( Ann )
import qualified Unison.Type as Type import qualified Unison.PrettyPrintEnv as PPE
import Unison.Util.PrettyPrint (PrettyPrint) import Unison.Reference ( Reference )
import qualified Unison.Util.PrettyPrint as PP import qualified Unison.Reference as Reference
import Unison.Util.AnnotatedText (AnnotatedText) import qualified Unison.Term as Term
import Unison.Util.ColorText (Color) import qualified Unison.TermPrinter as TermPrinter
import qualified Unison.Var as Var import qualified Unison.Type as Type
import qualified Unison.ABT as ABT import Unison.Util.PrettyPrint ( PrettyPrint )
import Unison.Names (Names(..), Name) 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 DataDeclaration v a = DD.DataDeclaration' v a
type EffectDeclaration v a = DD.EffectDeclaration' 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 () , putTerm :: Reference.Id -> Term v a -> Type v a -> m ()
, getTypeDeclaration :: Reference.Id -> m (Maybe (Decl v a)) , 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] , branches :: m [Name]
, getBranch :: Name -> m (Maybe Branch) , getBranch :: Name -> m (Maybe Branch)
-- thought: this merges the given branch with the existing 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 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) prettyBinding :: (Var.Var v, Monad m)
=> Codebase m v a -> Name -> Reference -> Branch -> m (Maybe (PrettyPrint String)) => Codebase m v a -> Name -> Reference -> Branch -> m (Maybe (PrettyPrint String))
prettyBinding _ _ (Reference.Builtin _) _ = pure Nothing prettyBinding _ _ (Reference.Builtin _) _ = pure Nothing
@ -123,8 +151,17 @@ branchToNames code b = case Branch.head b of
Branch0 {..} -> do Branch0 {..} -> do
let termRefs = Map.fromList $ R.toList termNamespace let termRefs = Map.fromList $ R.toList termNamespace
patterns = Map.fromList $ R.toList patternNamespace 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 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 (name, (Term.ref (ABT.annotation typ) ref, typ))
pure $ Names terms patterns types 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.Functor.Identity (runIdentity)
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as 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 Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
--import Control.Monad (join) --import Control.Monad (join)
import Unison.Codebase.Causal (Causal) import Unison.Codebase.Causal (Causal)
import qualified Unison.Codebase.Causal as 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 Unison.Codebase.TermEdit (TermEdit, Typing)
import qualified Unison.Codebase.TermEdit as TermEdit import qualified Unison.Codebase.TermEdit as TermEdit
import Unison.Codebase.TypeEdit (TypeEdit) import Unison.Codebase.TypeEdit (TypeEdit)
@ -35,6 +33,8 @@ import Unison.Hashable (Hashable)
import qualified Unison.Hashable as H import qualified Unison.Hashable as H
import Unison.Reference (Reference) import Unison.Reference (Reference)
import qualified Unison.UnisonFile as UF 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.Term as Term
import qualified Unison.Var as Var import qualified Unison.Var as Var
import Unison.Var (Var) import Unison.Var (Var)
@ -85,6 +85,22 @@ data Branch0 =
data Diff = Diff { ours :: Branch0, theirs :: 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 :: Branch -> Branch -> Diff
diff ours theirs = diff ours theirs =
let (ours', theirs') = join bimap (Causal.head . unbranch) (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 hasPatternNamed n b = not . null $ patternsNamed n b
termsNamed :: Name -> Branch -> Set Reference 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 -> 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 -> Branch -> Set (Reference, Int)
patternsNamed name = lookupDom name . patternNamespace . Causal.head . unbranch patternsNamed name =
R.lookupDom name . patternNamespace . Causal.head . unbranch
namesForTerm :: Reference -> Branch -> Set Name 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 :: 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 :: 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 :: Branch -> PrettyPrintEnv
prettyPrintEnv1 b = PrettyPrintEnv terms ctors patterns types where 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 -- build a map of those sets
foldl' go Map.empty (R.dom r) where foldl' go Map.empty (R.dom r) where
go m a = 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 in if Set.size bs > 1 then Map.insert a bs m else m
-- Use as `resolved editedTerms branch` -- 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' :: Ord a => Relation a b -> Map a b
resolved' r = foldl' go Map.empty (R.dom r) where resolved' r = foldl' go Map.empty (R.dom r) where
go m a = 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 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) -> Reference -> m (Relation Reference Name)
insertNames ops m r = foldl' (flip $ R.insert r) m <$> name ops r 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 :: Reference -> Reference -> Typing -> Branch -> Branch
replaceTerm old new typ (Branch b) = Branch $ Causal.step go b where replaceTerm old new typ (Branch b) = Branch $ Causal.step go b where
edit = TermEdit.Replace new typ edit = TermEdit.Replace new typ
go b = b { editedTerms = R.insert old edit (editedTerms b) 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. -- 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
deleteOrphans as b c = foldl' (\c a -> if R.memberDom a b then c else deleteDom a c) c as :: (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 :: Monad m => ReferenceOps m -> Branch -> m (Set Reference)
codebase ops (Branch (Causal.head -> Branch0 {..})) = codebase ops (Branch (Causal.head -> Branch0 {..})) =
@ -475,14 +466,14 @@ transitiveClosure1' f a = runIdentity $ transitiveClosure1 (pure.f) a
deprecateTerm :: Reference -> Branch -> Branch deprecateTerm :: Reference -> Branch -> Branch
deprecateTerm old (Branch b) = Branch $ Causal.step go b where deprecateTerm old (Branch b) = Branch $ Causal.step go b where
go b = b { editedTerms = R.insert old TermEdit.Deprecate (editedTerms b) 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 :: Reference -> Branch -> Branch
deprecateType old (Branch b) = Branch $ Causal.step go b where deprecateType old (Branch b) = Branch $ Causal.step go b where
go b = b { editedTypes = R.insert old TypeEdit.Deprecate (editedTypes b) 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 instance (Hashable a, Hashable b) => Hashable (Relation a b) where
@ -494,7 +485,7 @@ instance Hashable Branch0 where
H.tokens editedTerms ++ H.tokens editedTypes H.tokens editedTerms ++ H.tokens editedTypes
resolveTerm :: Name -> Branch -> Set Reference 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 :: Name -> Branch -> Maybe Reference
resolveTermUniquely n b = resolveTermUniquely n b =
@ -526,12 +517,12 @@ termOrTypeOp ops r ifTerm ifType = do
renameType :: Name -> Name -> Branch -> Branch renameType :: Name -> Name -> Branch -> Branch
renameType old new (Branch b) = renameType old new (Branch b) =
Branch $ Causal.stepIf (R.memberDom old . typeNamespace) go b where 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 :: Name -> Name -> Branch -> Branch
renameTerm old new (Branch b) = renameTerm old new (Branch b) =
Branch $ Causal.stepIf (R.memberDom old . termNamespace) go b where 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 :: Branch -> Hash
toHash = Causal.currentHash . unbranch toHash = Causal.currentHash . unbranch

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

@ -1,3 +1,4 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
@ -5,60 +6,82 @@
module Unison.Codebase.CommandLine (main) where module Unison.Codebase.CommandLine (main) where
import Data.Bifunctor (second) import Data.Bifunctor ( second )
import System.Random (randomRIO) import System.Random ( randomRIO )
import Control.Concurrent (forkIO) import Control.Concurrent ( forkIO )
import Control.Exception (catch, finally) import Control.Exception ( catch
import Control.Monad (forM_, forever, liftM2, , finally
void, when) )
import Control.Monad.STM (STM, atomically) import Control.Monad ( forM_
import qualified Data.Char as Char , forever
import Data.Foldable (toList, traverse_) , liftM2
import Data.IORef (IORef, newIORef, writeIORef, readIORef) , void
import Data.List (find, isSuffixOf, isPrefixOf, , when
sort) )
import Data.Set (Set) import Control.Monad.STM ( STM
import qualified Data.Set as Set , atomically
import Data.String (fromString) )
import Data.Strings (strPadLeft) import qualified Data.Char as Char
import Data.Text (Text, pack, unpack) 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 Data.Text.IO
import qualified System.Console.ANSI as Console import qualified System.Console.ANSI as Console
import System.FilePath (FilePath) import System.FilePath ( FilePath )
import qualified Text.Read as Read import qualified Text.Read as Read
import qualified Unison.Reference as Reference import qualified Unison.Reference as Reference
import System.IO.Error (isEOFError) import System.IO.Error ( isEOFError )
import qualified Unison.Builtin as B import qualified Unison.Builtin as B
import Unison.Codebase (Codebase) import Unison.Codebase ( Codebase )
import qualified Unison.Codebase as Codebase import qualified Unison.Codebase as Codebase
import Unison.Codebase.Branch (Branch) import Unison.Codebase.Branch ( Branch )
import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Branch as Branch
import Unison.Names (Name) import Unison.Names ( Name )
import Unison.Codebase.Runtime (Runtime) import Unison.Codebase.Runtime ( Runtime )
import qualified Unison.Codebase.Runtime as RT import qualified Unison.Codebase.Runtime as RT
import qualified Unison.Codebase.Watch as Watch import qualified Unison.Codebase.Watch as Watch
import Unison.FileParsers (parseAndSynthesizeFile) import Unison.FileParsers ( parseAndSynthesizeFile )
import qualified Unison.Parser as Parser import qualified Unison.Parser as Parser
import qualified Unison.PrintError as PrintError import qualified Unison.PrintError as PrintError
import Unison.PrintError (prettyParseError, import Unison.PrintError ( prettyParseError
prettyTypecheckedFile, , prettyTypecheckedFile
renderNoteAsANSI) , renderNoteAsANSI
import Unison.Result (pattern Result) )
import qualified Unison.Result as Result import Unison.Result ( pattern Result )
import qualified Unison.UnisonFile as UF import qualified Unison.Result as Result
import qualified Unison.Util.ColorText as Color import Unison.Symbol ( Symbol )
import qualified Unison.Util.Menu as Menu 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 Unison.Util.Monoid
import qualified Unison.Util.PrettyPrint as PP import qualified Unison.Util.PrettyPrint as PP
import Unison.Util.TQueue (TQueue) import Unison.Util.TQueue ( TQueue )
import qualified Unison.Util.TQueue as TQueue import qualified Unison.Util.TQueue as TQueue
import Unison.Var (Var) import Unison.Var ( Var )
import qualified Unison.Var as Var import qualified Unison.Var as Var
import qualified Data.Map as Map import qualified Data.Map as Map
import Unison.Parser (Ann) import Unison.Parser ( Ann )
import qualified Data.Text as Text import qualified Data.Text as Text
import Unison.Names (Names) import Unison.Names ( Names )
import qualified Unison.Term as Term import qualified Unison.Term as Term
data Event data Event
= UnisonFileChanged FilePath Text = 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." "\nUse the `> edit` command to have these definitions replace the existing ones."
go branch name go branch name
else do 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 () -- addFile :: Codebase -> TypecheckedUnisonFile -> m ()
let hashedTerms = UF.hashTerms typecheckedFile let hashedTerms = UF.hashTerms typecheckedFile
putStrLn $ "Adding the following definitions:" putStrLn $ "Adding the following definitions:"
@ -486,34 +510,40 @@ mergeBranchAndShowDiff codebase targetName sourceBranch = do
foo :: Text -> (String, Text) foo :: Text -> (String, Text)
foo name = (unpack name, name) 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 selectBranch codebase name takeLine = do
let branchMenu caption branches = let branchMenu caption branches = Menu.menu1
Menu.menu1 takeLine -- console
takeLine -- console caption -- caption
caption -- caption (fromString . unpack) -- render
(fromString . unpack) -- render (fromString . fmap Char.toLower . show) -- renderMeta
(fromString . fmap Char.toLower . show) -- renderMeta (foo <$> branches) -- groups
(foo <$> branches) -- groups [("create", Create), ("cancel", Cancel)] -- metas
[("create", Create), ("cancel", Cancel)] -- metas Nothing -- initial
Nothing -- initial
branch <- Codebase.getBranch codebase name branch <- Codebase.getBranch codebase name
case branch of case branch of
-- if branch named `name` exists, load it, -- if branch named `name` exists, load it,
Just branch -> pure . Just $ (name, branch) Just branch -> pure . Just $ (name, branch)
-- otherwise, -- otherwise,
-- list branches that do exist, plus option to create, plus option to cancel -- list branches that do exist, plus option to create, plus option to cancel
Nothing -> do Nothing -> do
let caption = fromString $ let caption =
"The branch " ++ show name ++ " doesn't exist. " ++ fromString
"Do you want to create it, or pick a different one?" $ "The branch "
++ show name
++ " doesn't exist. "
++ "Do you want to create it, or pick a different one?"
branches <- Codebase.branches codebase branches <- Codebase.branches codebase
choice <- branchMenu caption branches choice <- branchMenu caption branches
case choice of case choice of
Just (Left Cancel) -> pure Nothing Just (Left Cancel) -> pure Nothing
Just (Left Create) -> do Just (Left Create) -> do
branch <- mergeBranchAndShowDiff codebase name mempty branch <- mergeBranchAndShowDiff codebase name builtinBranch
pure $ Just (name, branch) pure $ Just (name, branch)
Just (Right name) -> selectBranch codebase name takeLine 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 :: FilePath -> FilePath
branchesPath path = path </> "branches" branchesPath path = path </> "branches"
branchPath :: FilePath -> Text -> FilePath branchPath :: FilePath -> Text -> FilePath
branchPath path name = branchesPath path </> Text.unpack name 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.Directory (doesFileExist, createDirectoryIfMissing)
import System.FilePath (takeDirectory) import System.FilePath (takeDirectory)
import Prelude hiding (readFile, writeFile) import Prelude hiding (readFile, writeFile)
import Debug.Trace
type Get a = forall m . MonadGet m => m a type Get a = forall m . MonadGet m => m a
type Put a = forall m . MonadPut m => a -> m () type Put a = forall m . MonadPut m => a -> m ()
@ -25,7 +24,7 @@ getFromBytes getA bytes =
getFromFile :: Get a -> FilePath -> IO (Maybe a) getFromFile :: Get a -> FilePath -> IO (Maybe a)
getFromFile getA file = do getFromFile getA file = do
b <- doesFileExist file 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 -> a -> ByteString
putBytes put a = runPutS (put a) 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 module Unison.Codebase.Serialization.V0 where
-- import qualified Data.Text as Text -- import qualified Data.Text as Text
import qualified Data.Vector as Vector import qualified Data.Vector as Vector
import qualified Unison.PatternP as Pattern import qualified Unison.PatternP as Pattern
import Unison.PatternP (Pattern) import Unison.PatternP ( Pattern )
import Control.Applicative (liftA2,liftA3) import Control.Applicative ( liftA2
import Control.Monad (replicateM) , liftA3
import Data.Bits (Bits) )
import Data.Bytes.Get import Control.Monad ( replicateM )
import Data.Bytes.Put import Data.Bits ( Bits )
import Data.Bytes.Serial (serialize, deserialize, serializeBE, deserializeBE) import Data.Bytes.Get
import Data.Bytes.Signed (Unsigned) import Data.Bytes.Put
import Data.Bytes.VarInt (VarInt(..)) import Data.Bytes.Serial ( serialize
import Data.Foldable (traverse_) , deserialize
import Data.Int (Int64) , serializeBE
import Data.List (elemIndex, foldl') , deserializeBE
import Data.Text (Text) )
import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Bytes.Signed ( Unsigned )
import Data.Relation (Relation) import Data.Bytes.VarInt ( VarInt(..) )
import Data.Word (Word64) import Data.Foldable ( traverse_ )
import Unison.Codebase.Branch (Branch(..), Branch0(..)) import Data.Int ( Int64 )
import Unison.Codebase.Causal (Causal) import Data.List ( elemIndex
import Unison.Codebase.TermEdit (TermEdit) , foldl'
import Unison.Codebase.TypeEdit (TypeEdit) )
import Unison.Hash (Hash) import Data.Text ( Text )
import Unison.Kind (Kind) import Data.Text.Encoding ( encodeUtf8
import Unison.Reference (Reference) , decodeUtf8
import Unison.Symbol (Symbol(..)) )
import Unison.Term (AnnotatedTerm) import Data.Word ( Word64 )
import qualified Data.ByteString as B import Unison.Codebase.Branch ( Branch(..)
import qualified Data.Map as Map , Branch0(..)
import qualified Data.Set as Set )
import qualified Unison.ABT as ABT import Unison.Codebase.Causal ( Causal )
import qualified Unison.Codebase.Causal as Causal import Unison.Codebase.TermEdit ( TermEdit )
import qualified Unison.Codebase.TermEdit as TermEdit import Unison.Codebase.TypeEdit ( TypeEdit )
import qualified Unison.Codebase.TypeEdit as 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.Codebase.Serialization as S
import qualified Unison.Hash as Hash import qualified Unison.Hash as Hash
import qualified Unison.Kind as Kind import qualified Unison.Kind as Kind
import qualified Unison.Reference as Reference import qualified Unison.Reference as Reference
import qualified Data.Relation as Relation import qualified Unison.Term as Term
import qualified Unison.Term as Term import qualified Unison.Type as Type
import qualified Unison.Type as Type import Unison.Util.Relation ( Relation )
import qualified Unison.DataDeclaration as DataDeclaration import qualified Unison.Util.Relation as Relation
import Unison.DataDeclaration (DataDeclaration', EffectDeclaration') import qualified Unison.DataDeclaration as DataDeclaration
import Unison.DataDeclaration ( DataDeclaration'
, EffectDeclaration'
)
-- ABOUT THIS FORMAT: -- 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)] constructors' :: [(a, v, AnnotatedType v a)]
} deriving (Show, Functor) } 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' v a -> [(v, AnnotatedType v a)]
constructors (DataDeclaration _ _ ctors) = [(v,t) | (_,v,t) <- ctors ] 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 hashComponents m = Reference.hashComponents (\r -> ref() r) m
-- The hash for a constructor -- 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 :: Reference -> Int -> Reference
hashConstructor r cid = let hashConstructor = hashConstructor' $ constructor ()
-- this is a bit circuitous, but defining everything in terms of hashComponents
-- ensure the hashing is always done in the same way hashRequest :: Reference -> Int -> Reference
m = hashComponents (Map.fromList [(Var.named "_" :: Symbol, constructor() r cid)]) hashRequest = hashConstructor' $ request ()
in case toList m of
[(r,_)] -> r
_ -> error "unpossible"
anf :: ∀ vt at v a . (Semigroup a, Var v) anf :: ∀ vt at v a . (Semigroup a, Var v)
=> AnnotatedTerm2 vt at a v a -> AnnotatedTerm2 vt at a v a => 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.Monoid
Unison.Util.PrettyPrint Unison.Util.PrettyPrint
Unison.Util.Range Unison.Util.Range
Unison.Util.Relation
Unison.Util.TQueue Unison.Util.TQueue
Unison.Var Unison.Var
@ -127,7 +128,6 @@ library
megaparsec, megaparsec,
prelude-extras, prelude-extras,
random, random,
relation,
safe, safe,
stm, stm,
strings, strings,

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

@ -3,40 +3,51 @@
module Main where module Main where
import Data.Char (toLower) import Data.Char ( toLower )
import Safe (headMay) import Safe ( headMay )
import System.Environment (getArgs) import System.Environment ( getArgs )
import System.IO (BufferMode (NoBuffering), import System.IO ( BufferMode(NoBuffering)
hSetBuffering, stdout) , hSetBuffering
import qualified Unison.Codebase.CommandLine as CommandLine , stdout
import qualified Unison.Codebase.FileCodebase as FileCodebase )
import Unison.Codebase.Runtime.JVM (javaRuntime) import qualified Unison.Codebase as Codebase
import qualified Unison.Codebase.Serialization as S import qualified Unison.Codebase.CommandLine as CommandLine
import Unison.Codebase.Serialization.V0 (formatSymbol, getSymbol) import qualified Unison.Codebase.FileCodebase as FileCodebase
import Unison.Parser (Ann (External)) 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 :: IO ()
main = do main = do
args <- getArgs args <- getArgs
hSetBuffering stdout NoBuffering -- cool hSetBuffering stdout NoBuffering -- cool
let codebasePath = ".unison" let codebasePath = ".unison"
initialBranchName = "master" initialBranchName = "master"
scratchFilePath = "." scratchFilePath = "."
launch = CommandLine.main scratchFilePath initialBranchName theCodebase =
(headMay args) FileCodebase.codebase1 External formatSymbol formatAnn codebasePath
(javaRuntime getSymbol 42441) launch = CommandLine.main scratchFilePath
(FileCodebase.codebase1 External formatSymbol formatAnn codebasePath) initialBranchName
(headMay args)
(javaRuntime getSymbol 42441)
theCodebase
exists <- FileCodebase.exists codebasePath exists <- FileCodebase.exists codebasePath
case exists of case exists of
True -> launch True -> launch
False -> do 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 line <- getLine
case words (map toLower line) of case words (map toLower line) of
('y':_):_ -> FileCodebase.initialize codebasePath *> launch ('y' : _) : _ -> do
_ -> pure () FileCodebase.initialize codebasePath
Codebase.initialize theCodebase
launch
_ -> pure ()
formatAnn :: S.Format Ann formatAnn :: S.Format Ann
formatAnn = S.Format (pure External) (\_ -> pure ()) formatAnn = S.Format (pure External) (\_ -> pure ())