mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-21 07:17:25 +03:00
⅄ trunk → 21-10-07-name-refactor
This commit is contained in:
commit
fc7b6d9c22
@ -58,3 +58,4 @@ The format for this list: name, GitHub handle, and then optional blurb about wha
|
||||
* David Smith (@shmish111)
|
||||
* Chris Penner (@ChrisPenner)
|
||||
* Rebecca Mark (@rlmark)
|
||||
* Evan Minsk (@iamevn)
|
||||
|
6
hie.yaml
6
hie.yaml
@ -45,11 +45,11 @@ cradle:
|
||||
- path: "parser-typechecker/tests"
|
||||
component: "unison-parser-typechecker:exe:tests"
|
||||
|
||||
- path: "cli/transcripts"
|
||||
- path: "unison-cli/transcripts"
|
||||
component: "unison-cli:exe:transcripts"
|
||||
|
||||
- path: "cli/unison"
|
||||
component: "cli:exe:unison"
|
||||
- path: "unison-cli/unison"
|
||||
component: "unison-cli:exe:unison"
|
||||
|
||||
- path: "parser-typechecker/benchmarks/runtime"
|
||||
component: "unison-parser-typechecker:bench:runtime"
|
||||
|
@ -94,6 +94,7 @@ library:
|
||||
- safe-exceptions
|
||||
- mwc-random
|
||||
- NanoID
|
||||
- lucid
|
||||
- servant
|
||||
- servant-docs
|
||||
- servant-openapi3
|
||||
|
@ -138,7 +138,7 @@ openNewUcmCodebaseOrExit cbInit debugName path = do
|
||||
Codebase.installUcmDependencies codebase
|
||||
pure x
|
||||
|
||||
-- | try to init a codebase where none exists and then exit regardless (i.e. `ucm -codebase dir init`)
|
||||
-- | try to init a codebase where none exists and then exit regardless (i.e. `ucm --codebase dir init`)
|
||||
initCodebaseAndExit :: MonadIO m => Init m Symbol Ann -> DebugName -> Maybe CodebasePath -> m ()
|
||||
initCodebaseAndExit i debugName mdir =
|
||||
void $ openNewUcmCodebaseOrExit i debugName =<< Codebase.getCodebaseDir mdir
|
||||
|
@ -289,7 +289,7 @@ run dir configFile stanzas codebase = do
|
||||
"\128721", "",
|
||||
"The transcript failed due to an error in the stanza above. The error is:", "",
|
||||
Text.pack msg, "",
|
||||
"Run `" <> Text.pack executable <> " -codebase " <> Text.pack dir <> "` " <> "to do more work with it."]
|
||||
"Run `" <> Text.pack executable <> " --codebase " <> Text.pack dir <> "` " <> "to do more work with it."]
|
||||
|
||||
dieUnexpectedSuccess :: IO ()
|
||||
dieUnexpectedSuccess = do
|
||||
@ -302,7 +302,7 @@ run dir configFile stanzas codebase = do
|
||||
transcriptFailure out $ Text.unlines [
|
||||
"\128721", "",
|
||||
"The transcript was expecting an error in the stanza above, but did not encounter one.", "",
|
||||
"Run `" <> Text.pack executable <> " -codebase " <> Text.pack dir <> "` " <> "to do more work with it."]
|
||||
"Run `" <> Text.pack executable <> " --codebase " <> Text.pack dir <> "` " <> "to do more work with it."]
|
||||
|
||||
loop state = do
|
||||
writeIORef pathRef (view HandleInput.currentPath state)
|
||||
|
@ -5,7 +5,6 @@ module Unison.Hashing.V2.Convert
|
||||
hashDecls,
|
||||
hashClosedTerm,
|
||||
hashTermComponents,
|
||||
hashTypeComponents,
|
||||
typeToReference,
|
||||
typeToReferenceMentions,
|
||||
)
|
||||
@ -38,12 +37,6 @@ typeToReference = h2mReference . Hashing.Type.toReference . m2hType . Memory.Typ
|
||||
typeToReferenceMentions :: Var v => Memory.Type.Type v a -> Set Memory.Reference.Reference
|
||||
typeToReferenceMentions = Set.map h2mReference . Hashing.Type.toReferenceMentions . m2hType . Memory.Type.removeAllEffectVars
|
||||
|
||||
hashTypeComponents :: Var v => Map v (Memory.Type.Type v a) -> Map v (Memory.Reference.Id, Memory.Type.Type v a)
|
||||
hashTypeComponents = fmap h2mTypeResult . Hashing.Type.hashComponents . fmap m2hType
|
||||
where
|
||||
h2mTypeResult :: Ord v => (Hashing.Reference.Id, Hashing.Type.Type v a) -> (Memory.Reference.Id, Memory.Type.Type v a)
|
||||
h2mTypeResult (id, tp) = (h2mReferenceId id, h2mType tp)
|
||||
|
||||
hashTermComponents :: Var v => Map v (Memory.Term.Term v a) -> Map v (Memory.Reference.Id, Memory.Term.Term v a)
|
||||
hashTermComponents = fmap h2mTermResult . Hashing.Term.hashComponents . fmap m2hTerm
|
||||
where
|
||||
|
@ -25,7 +25,6 @@ import Control.Lens (over, _3)
|
||||
import Data.Bifunctor (first, second)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import Prelude.Extras (Show1)
|
||||
import Unison.Var (Var)
|
||||
import qualified Unison.ABT as ABT
|
||||
import qualified Unison.ConstructorType as CT
|
||||
@ -40,17 +39,10 @@ import qualified Unison.Hashing.V2.Type as Type
|
||||
import qualified Unison.Name as Name
|
||||
import qualified Unison.Names.ResolutionResult as Names
|
||||
import Unison.Prelude
|
||||
-- import qualified Unison.Referent as Referent
|
||||
-- import qualified Unison.Referent' as Referent'
|
||||
import Prelude hiding (cycle)
|
||||
|
||||
type Decl v a = Either (EffectDeclaration v a) (DataDeclaration v a)
|
||||
|
||||
data DeclOrBuiltin v a
|
||||
= Builtin CT.ConstructorType
|
||||
| Decl (Decl v a)
|
||||
deriving (Eq, Show)
|
||||
|
||||
asDataDecl :: Decl v a -> DataDeclaration v a
|
||||
asDataDecl = either toDataDecl id
|
||||
|
||||
@ -71,12 +63,12 @@ data DataDeclaration v a = DataDeclaration
|
||||
bound :: [v],
|
||||
constructors' :: [(a, v, Type v a)]
|
||||
}
|
||||
deriving (Eq, Show, Functor)
|
||||
deriving (Functor)
|
||||
|
||||
newtype EffectDeclaration v a = EffectDeclaration
|
||||
{ toDataDecl :: DataDeclaration v a
|
||||
}
|
||||
deriving (Eq, Show, Functor)
|
||||
deriving (Functor)
|
||||
|
||||
constructorTypes :: DataDeclaration v a -> [Type v a]
|
||||
constructorTypes = (snd <$>) . constructors
|
||||
@ -148,7 +140,7 @@ data F a
|
||||
| LetRec [a] a
|
||||
| Constructors [a]
|
||||
| Modified Modifier a
|
||||
deriving (Functor, Foldable, Show, Show1)
|
||||
deriving (Functor, Foldable)
|
||||
|
||||
instance Hashable1 F where
|
||||
hash1 hashCycle hash e =
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -5,27 +5,40 @@
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Unison.Hashing.V2.Type where
|
||||
module Unison.Hashing.V2.Type
|
||||
(
|
||||
Type,
|
||||
F(..),
|
||||
bindExternal,
|
||||
bindReferences,
|
||||
dependencies,
|
||||
-- * find by type index stuff
|
||||
toReference,
|
||||
toReferenceMentions,
|
||||
-- * builtin term references
|
||||
booleanRef,
|
||||
charRef,
|
||||
effectRef,
|
||||
floatRef,
|
||||
intRef,
|
||||
listRef,
|
||||
natRef,
|
||||
textRef,
|
||||
)
|
||||
where
|
||||
|
||||
import Unison.Prelude
|
||||
|
||||
import qualified Control.Monad.Writer.Strict as Writer
|
||||
import Data.Functor.Identity (runIdentity)
|
||||
import Data.Monoid (Any(..))
|
||||
import Data.List.Extra (nubOrd)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import Prelude.Extras (Eq1(..),Show1(..),Ord1(..))
|
||||
import qualified Unison.ABT as ABT
|
||||
import Unison.Hashable (Hashable1)
|
||||
import qualified Unison.Hashable as Hashable
|
||||
import qualified Unison.Kind as K
|
||||
import Unison.Hashing.V2.Reference (Reference)
|
||||
import qualified Unison.Hashing.V2.Reference as Reference
|
||||
import qualified Unison.Hashing.V2.Reference.Util as ReferenceUtil
|
||||
import Unison.Var (Var)
|
||||
import qualified Unison.Var as Var
|
||||
import qualified Unison.Settings as Settings
|
||||
import qualified Unison.Names.ResolutionResult as Names
|
||||
import qualified Unison.Name as Name
|
||||
import qualified Unison.Util.List as List
|
||||
@ -42,18 +55,11 @@ data F a
|
||||
| IntroOuter a -- binder like ∀, used to introduce variables that are
|
||||
-- bound by outer type signatures, to support scoped type
|
||||
-- variables
|
||||
deriving (Foldable,Functor,Generic,Generic1,Eq,Ord,Traversable)
|
||||
|
||||
instance Eq1 F where (==#) = (==)
|
||||
instance Ord1 F where compare1 = compare
|
||||
instance Show1 F where showsPrec1 = showsPrec
|
||||
deriving (Foldable,Functor,Traversable)
|
||||
|
||||
-- | Types are represented as ABTs over the base functor F, with variables in `v`
|
||||
type Type v a = ABT.Term F v a
|
||||
|
||||
wrapV :: Ord v => Type v a -> Type (ABT.V v) a
|
||||
wrapV = ABT.vmap ABT.Bound
|
||||
|
||||
freeVars :: Type v a -> Set v
|
||||
freeVars = ABT.freeVars
|
||||
|
||||
@ -74,107 +80,10 @@ bindReferences keepFree ns t = let
|
||||
ok (v, a, Nothing) = Left (pure (Names.TypeResolutionFailure v a Names.NotFound))
|
||||
in List.validate ok rs <&> \es -> bindExternal es t
|
||||
|
||||
bindNames
|
||||
:: Var v
|
||||
=> Set v
|
||||
-> Map Name.Name Reference
|
||||
-> Type v a
|
||||
-> Names.ResolutionResult v a (Type v a)
|
||||
bindNames keepFree ns t = let
|
||||
fvs = ABT.freeVarOccurrences keepFree t
|
||||
rs = [(v, a, Map.lookup (Name.unsafeFromVar v) ns) | (v, a) <- fvs]
|
||||
ok (v, _a, Just r) = pure (v, r)
|
||||
ok (v, a, Nothing) = Left (pure (Names.TypeResolutionFailure v a Names.NotFound))
|
||||
in List.validate ok rs <&> \es -> bindExternal es t
|
||||
|
||||
newtype Monotype v a = Monotype { getPolytype :: Type v a } deriving Eq
|
||||
|
||||
instance (Show v) => Show (Monotype v a) where
|
||||
show = show . getPolytype
|
||||
|
||||
-- Smart constructor which checks if a `Type` has no `Forall` quantifiers.
|
||||
monotype :: ABT.Var v => Type v a -> Maybe (Monotype v a)
|
||||
monotype t = Monotype <$> ABT.visit isMono t where
|
||||
isMono (Forall' _) = Just Nothing
|
||||
isMono _ = Nothing
|
||||
|
||||
arity :: Type v a -> Int
|
||||
arity (ForallNamed' _ body) = arity body
|
||||
arity (Arrow' _ o) = 1 + arity o
|
||||
arity (Ann' a _) = arity a
|
||||
arity _ = 0
|
||||
|
||||
-- some smart patterns
|
||||
pattern Ref' r <- ABT.Tm' (Ref r)
|
||||
pattern Arrow' i o <- ABT.Tm' (Arrow i o)
|
||||
pattern Arrow'' i es o <- Arrow' i (Effect'' es o)
|
||||
pattern Arrows' spine <- (unArrows -> Just spine)
|
||||
pattern EffectfulArrows' fst rest <- (unEffectfulArrows -> Just (fst, rest))
|
||||
pattern Ann' t k <- ABT.Tm' (Ann t k)
|
||||
pattern App' f x <- ABT.Tm' (App f x)
|
||||
pattern Apps' f args <- (unApps -> Just (f, args))
|
||||
pattern Pure' t <- (unPure -> Just t)
|
||||
pattern Effects' es <- ABT.Tm' (Effects es)
|
||||
-- Effect1' must match at least one effect
|
||||
pattern Effect1' e t <- ABT.Tm' (Effect e t)
|
||||
pattern Effect' es t <- (unEffects1 -> Just (es, t))
|
||||
pattern Effect'' es t <- (unEffect0 -> (es, t))
|
||||
-- Effect0' may match zero effects
|
||||
pattern Effect0' es t <- (unEffect0 -> (es, t))
|
||||
pattern Forall' subst <- ABT.Tm' (Forall (ABT.Abs' subst))
|
||||
pattern IntroOuter' subst <- ABT.Tm' (IntroOuter (ABT.Abs' subst))
|
||||
pattern IntroOuterNamed' v body <- ABT.Tm' (IntroOuter (ABT.out -> ABT.Abs v body))
|
||||
pattern ForallsNamed' vs body <- (unForalls -> Just (vs, body))
|
||||
pattern ForallNamed' v body <- ABT.Tm' (Forall (ABT.out -> ABT.Abs v body))
|
||||
pattern Var' v <- ABT.Var' v
|
||||
pattern Cycle' xs t <- ABT.Cycle' xs t
|
||||
pattern Abs' subst <- ABT.Abs' subst
|
||||
|
||||
unPure :: Ord v => Type v a -> Maybe (Type v a)
|
||||
unPure (Effect'' [] t) = Just t
|
||||
unPure (Effect'' _ _) = Nothing
|
||||
unPure t = Just t
|
||||
|
||||
unArrows :: Type v a -> Maybe [Type v a]
|
||||
unArrows t =
|
||||
case go t of [_] -> Nothing; l -> Just l
|
||||
where go (Arrow' i o) = i : go o
|
||||
go o = [o]
|
||||
|
||||
unEffectfulArrows
|
||||
:: Type v a -> Maybe (Type v a, [(Maybe [Type v a], Type v a)])
|
||||
unEffectfulArrows t = case t of
|
||||
Arrow' i o -> Just (i, go o)
|
||||
_ -> Nothing
|
||||
where
|
||||
go (Effect1' (Effects' es) (Arrow' i o)) =
|
||||
(Just $ es >>= flattenEffects, i) : go o
|
||||
go (Effect1' (Effects' es) t) = [(Just $ es >>= flattenEffects, t)]
|
||||
go (Arrow' i o) = (Nothing, i) : go o
|
||||
go t = [(Nothing, t)]
|
||||
|
||||
unApps :: Type v a -> Maybe (Type v a, [Type v a])
|
||||
unApps t = case go t [] of
|
||||
[] -> Nothing
|
||||
[ _ ] -> Nothing
|
||||
f : args -> Just (f, args)
|
||||
where
|
||||
go (App' i o) acc = go i (o : acc)
|
||||
go fn args = fn : args
|
||||
|
||||
unIntroOuters :: Type v a -> Maybe ([v], Type v a)
|
||||
unIntroOuters t = go t []
|
||||
where go (IntroOuterNamed' v body) vs = go body (v:vs)
|
||||
go _body [] = Nothing
|
||||
go body vs = Just (reverse vs, body)
|
||||
|
||||
-- Most code doesn't care about `introOuter` binders and is fine dealing with the
|
||||
-- these outer variable references as free variables. This function strips out
|
||||
-- one or more `introOuter` binders, so `outer a b . (a, b)` becomes `(a, b)`.
|
||||
stripIntroOuters :: Type v a -> Type v a
|
||||
stripIntroOuters t = case unIntroOuters t of
|
||||
Just (_, t) -> t
|
||||
Nothing -> t
|
||||
|
||||
unForalls :: Type v a -> Maybe ([v], Type v a)
|
||||
unForalls t = go t []
|
||||
@ -182,38 +91,11 @@ unForalls t = go t []
|
||||
go _body [] = Nothing
|
||||
go body vs = Just(reverse vs, body)
|
||||
|
||||
unEffect0 :: Ord v => Type v a -> ([Type v a], Type v a)
|
||||
unEffect0 (Effect1' e a) = (flattenEffects e, a)
|
||||
unEffect0 t = ([], t)
|
||||
|
||||
unEffects1 :: Ord v => Type v a -> Maybe ([Type v a], Type v a)
|
||||
unEffects1 (Effect1' (Effects' es) a) = Just (es, a)
|
||||
unEffects1 _ = Nothing
|
||||
|
||||
-- | True if the given type is a function, possibly quantified
|
||||
isArrow :: ABT.Var v => Type v a -> Bool
|
||||
isArrow (ForallNamed' _ t) = isArrow t
|
||||
isArrow (Arrow' _ _) = True
|
||||
isArrow _ = False
|
||||
|
||||
-- some smart constructors
|
||||
|
||||
ref :: Ord v => a -> Reference -> Type v a
|
||||
ref a = ABT.tm' a . Ref
|
||||
|
||||
refId :: Ord v => a -> Reference.Id -> Type v a
|
||||
refId a = ref a . Reference.DerivedId
|
||||
|
||||
termLink :: Ord v => a -> Type v a
|
||||
termLink a = ABT.tm' a . Ref $ termLinkRef
|
||||
|
||||
typeLink :: Ord v => a -> Type v a
|
||||
typeLink a = ABT.tm' a . Ref $ typeLinkRef
|
||||
|
||||
derivedBase32Hex :: Ord v => Reference -> a -> Type v a
|
||||
derivedBase32Hex r a = ref a r
|
||||
|
||||
intRef, natRef, floatRef, booleanRef, textRef, charRef, listRef, bytesRef, effectRef, termLinkRef, typeLinkRef :: Reference
|
||||
intRef, natRef, floatRef, booleanRef, textRef, charRef, listRef, effectRef :: Reference
|
||||
intRef = Reference.Builtin "Int"
|
||||
natRef = Reference.Builtin "Nat"
|
||||
floatRef = Reference.Builtin "Float"
|
||||
@ -221,223 +103,11 @@ booleanRef = Reference.Builtin "Boolean"
|
||||
textRef = Reference.Builtin "Text"
|
||||
charRef = Reference.Builtin "Char"
|
||||
listRef = Reference.Builtin "Sequence"
|
||||
bytesRef = Reference.Builtin "Bytes"
|
||||
effectRef = Reference.Builtin "Effect"
|
||||
termLinkRef = Reference.Builtin "Link.Term"
|
||||
typeLinkRef = Reference.Builtin "Link.Type"
|
||||
|
||||
builtinIORef, fileHandleRef, filePathRef, threadIdRef, socketRef :: Reference
|
||||
builtinIORef = Reference.Builtin "IO"
|
||||
fileHandleRef = Reference.Builtin "Handle"
|
||||
filePathRef = Reference.Builtin "FilePath"
|
||||
threadIdRef = Reference.Builtin "ThreadId"
|
||||
socketRef = Reference.Builtin "Socket"
|
||||
|
||||
mvarRef, tvarRef :: Reference
|
||||
mvarRef = Reference.Builtin "MVar"
|
||||
tvarRef = Reference.Builtin "TVar"
|
||||
|
||||
tlsRef :: Reference
|
||||
tlsRef = Reference.Builtin "Tls"
|
||||
|
||||
stmRef :: Reference
|
||||
stmRef = Reference.Builtin "STM"
|
||||
|
||||
tlsClientConfigRef :: Reference
|
||||
tlsClientConfigRef = Reference.Builtin "Tls.ClientConfig"
|
||||
|
||||
tlsServerConfigRef :: Reference
|
||||
tlsServerConfigRef = Reference.Builtin "Tls.ServerConfig"
|
||||
|
||||
tlsSignedCertRef :: Reference
|
||||
tlsSignedCertRef = Reference.Builtin "Tls.SignedCert"
|
||||
|
||||
tlsPrivateKeyRef :: Reference
|
||||
tlsPrivateKeyRef = Reference.Builtin "Tls.PrivateKey"
|
||||
|
||||
tlsCipherRef :: Reference
|
||||
tlsCipherRef = Reference.Builtin "Tls.Cipher"
|
||||
|
||||
tlsVersionRef :: Reference
|
||||
tlsVersionRef = Reference.Builtin "Tls.Version"
|
||||
|
||||
hashAlgorithmRef :: Reference
|
||||
hashAlgorithmRef = Reference.Builtin "crypto.HashAlgorithm"
|
||||
|
||||
codeRef, valueRef :: Reference
|
||||
codeRef = Reference.Builtin "Code"
|
||||
valueRef = Reference.Builtin "Value"
|
||||
|
||||
anyRef :: Reference
|
||||
anyRef = Reference.Builtin "Any"
|
||||
|
||||
any :: Ord v => a -> Type v a
|
||||
any a = ref a anyRef
|
||||
|
||||
builtin :: Ord v => a -> Text -> Type v a
|
||||
builtin a = ref a . Reference.Builtin
|
||||
|
||||
int :: Ord v => a -> Type v a
|
||||
int a = ref a intRef
|
||||
|
||||
nat :: Ord v => a -> Type v a
|
||||
nat a = ref a natRef
|
||||
|
||||
float :: Ord v => a -> Type v a
|
||||
float a = ref a floatRef
|
||||
|
||||
boolean :: Ord v => a -> Type v a
|
||||
boolean a = ref a booleanRef
|
||||
|
||||
text :: Ord v => a -> Type v a
|
||||
text a = ref a textRef
|
||||
|
||||
char :: Ord v => a -> Type v a
|
||||
char a = ref a charRef
|
||||
|
||||
fileHandle :: Ord v => a -> Type v a
|
||||
fileHandle a = ref a fileHandleRef
|
||||
|
||||
threadId :: Ord v => a -> Type v a
|
||||
threadId a = ref a threadIdRef
|
||||
|
||||
builtinIO :: Ord v => a -> Type v a
|
||||
builtinIO a = ref a builtinIORef
|
||||
|
||||
socket :: Ord v => a -> Type v a
|
||||
socket a = ref a socketRef
|
||||
|
||||
list :: Ord v => a -> Type v a
|
||||
list a = ref a listRef
|
||||
|
||||
bytes :: Ord v => a -> Type v a
|
||||
bytes a = ref a bytesRef
|
||||
|
||||
effectType :: Ord v => a -> Type v a
|
||||
effectType a = ref a $ effectRef
|
||||
|
||||
code, value :: Ord v => a -> Type v a
|
||||
code a = ref a codeRef
|
||||
value a = ref a valueRef
|
||||
|
||||
app :: Ord v => a -> Type v a -> Type v a -> Type v a
|
||||
app a f arg = ABT.tm' a (App f arg)
|
||||
|
||||
-- `f x y z` means `((f x) y) z` and the annotation paired with `y` is the one
|
||||
-- meant for `app (f x) y`
|
||||
apps :: Ord v => Type v a -> [(a, Type v a)] -> Type v a
|
||||
apps = foldl' go where go f (a, t) = app a f t
|
||||
|
||||
app' :: (Ord v, Semigroup a) => Type v a -> Type v a -> Type v a
|
||||
app' f arg = app (ABT.annotation f <> ABT.annotation arg) f arg
|
||||
|
||||
apps' :: (Semigroup a, Ord v) => Type v a -> [Type v a] -> Type v a
|
||||
apps' = foldl app'
|
||||
|
||||
arrow :: Ord v => a -> Type v a -> Type v a -> Type v a
|
||||
arrow a i o = ABT.tm' a (Arrow i o)
|
||||
|
||||
arrow' :: (Semigroup a, Ord v) => Type v a -> Type v a -> Type v a
|
||||
arrow' i o = arrow (ABT.annotation i <> ABT.annotation o) i o
|
||||
|
||||
ann :: Ord v => a -> Type v a -> K.Kind -> Type v a
|
||||
ann a e t = ABT.tm' a (Ann e t)
|
||||
|
||||
forall :: Ord v => a -> v -> Type v a -> Type v a
|
||||
forall a v body = ABT.tm' a (Forall (ABT.abs' a v body))
|
||||
|
||||
introOuter :: Ord v => a -> v -> Type v a -> Type v a
|
||||
introOuter a v body = ABT.tm' a (IntroOuter (ABT.abs' a v body))
|
||||
|
||||
iff :: Var v => Type v ()
|
||||
iff = forall () aa $ arrows (f <$> [boolean(), a, a]) a
|
||||
where aa = Var.named "a"
|
||||
a = var () aa
|
||||
f x = ((), x)
|
||||
|
||||
iff' :: Var v => a -> Type v a
|
||||
iff' loc = forall loc aa $ arrows (f <$> [boolean loc, a, a]) a
|
||||
where aa = Var.named "a"
|
||||
a = var loc aa
|
||||
f x = (loc, x)
|
||||
|
||||
iff2 :: Var v => a -> Type v a
|
||||
iff2 loc = forall loc aa $ arrows (f <$> [a, a]) a
|
||||
where aa = Var.named "a"
|
||||
a = var loc aa
|
||||
f x = (loc, x)
|
||||
|
||||
andor :: Ord v => Type v ()
|
||||
andor = arrows (f <$> [boolean(), boolean()]) $ boolean()
|
||||
where f x = ((), x)
|
||||
|
||||
andor' :: Ord v => a -> Type v a
|
||||
andor' a = arrows (f <$> [boolean a, boolean a]) $ boolean a
|
||||
where f x = (a, x)
|
||||
|
||||
var :: Ord v => a -> v -> Type v a
|
||||
var = ABT.annotatedVar
|
||||
|
||||
v' :: Var v => Text -> Type v ()
|
||||
v' s = ABT.var (Var.named s)
|
||||
|
||||
-- Like `v'`, but creates an annotated variable given an annotation
|
||||
av' :: Var v => a -> Text -> Type v a
|
||||
av' a s = ABT.annotatedVar a (Var.named s)
|
||||
|
||||
forall' :: Var v => a -> [Text] -> Type v a -> Type v a
|
||||
forall' a vs body = foldr (forall a) body (Var.named <$> vs)
|
||||
|
||||
foralls :: Ord v => a -> [v] -> Type v a -> Type v a
|
||||
foralls a vs body = foldr (forall a) body vs
|
||||
|
||||
-- Note: `a -> b -> c` parses as `a -> (b -> c)`
|
||||
-- the annotation associated with `b` will be the annotation for the `b -> c`
|
||||
-- node
|
||||
arrows :: Ord v => [(a, Type v a)] -> Type v a -> Type v a
|
||||
arrows ts result = foldr go result ts where
|
||||
go = uncurry arrow
|
||||
|
||||
-- The types of effectful computations
|
||||
effect :: Ord v => a -> [Type v a] -> Type v a -> Type v a
|
||||
effect a es (Effect1' fs t) =
|
||||
let es' = (es >>= flattenEffects) ++ flattenEffects fs
|
||||
in ABT.tm' a (Effect (ABT.tm' a (Effects es')) t)
|
||||
effect a es t = ABT.tm' a (Effect (ABT.tm' a (Effects es)) t)
|
||||
|
||||
effects :: Ord v => a -> [Type v a] -> Type v a
|
||||
effects a es = ABT.tm' a (Effects $ es >>= flattenEffects)
|
||||
|
||||
effect1 :: Ord v => a -> Type v a -> Type v a -> Type v a
|
||||
effect1 a es (Effect1' fs t) =
|
||||
let es' = flattenEffects es ++ flattenEffects fs
|
||||
in ABT.tm' a (Effect (ABT.tm' a (Effects es')) t)
|
||||
effect1 a es t = ABT.tm' a (Effect es t)
|
||||
|
||||
flattenEffects :: Type v a -> [Type v a]
|
||||
flattenEffects (Effects' es) = es >>= flattenEffects
|
||||
flattenEffects es = [es]
|
||||
|
||||
-- The types of first-class effect values
|
||||
-- which get deconstructed in effect handlers.
|
||||
effectV :: Ord v => a -> (a, Type v a) -> (a, Type v a) -> Type v a
|
||||
effectV builtinA e t = apps (builtin builtinA "Effect") [e, t]
|
||||
|
||||
-- Strips effects from a type. E.g. `{e} a` becomes `a`.
|
||||
stripEffect :: Ord v => Type v a -> ([Type v a], Type v a)
|
||||
stripEffect (Effect' e t) = case stripEffect t of (ei, t) -> (e ++ ei, t)
|
||||
stripEffect t = ([], t)
|
||||
|
||||
-- The type of the flipped function application operator:
|
||||
-- `(a -> (a -> b) -> b)`
|
||||
flipApply :: Var v => Type v () -> Type v ()
|
||||
flipApply t = forall() b $ arrow() (arrow() t (var() b)) (var() b)
|
||||
where b = ABT.fresh t (Var.named "b")
|
||||
|
||||
generalize' :: Var v => Var.Type -> Type v a -> Type v a
|
||||
generalize' k t = generalize vsk t where
|
||||
vsk = [ v | v <- Set.toList (freeVars t), Var.typeOf v == k ]
|
||||
|
||||
-- | Bind the given variables with an outer `forall`, if they are used in `t`.
|
||||
generalize :: Ord v => [v] -> Type v a -> Type v a
|
||||
generalize vs t = foldr f t vs
|
||||
@ -445,10 +115,6 @@ generalize vs t = foldr f t vs
|
||||
f v t =
|
||||
if Set.member v (ABT.freeVars t) then forall (ABT.annotation t) v t else t
|
||||
|
||||
unforall :: Type v a -> Type v a
|
||||
unforall (ForallsNamed' _ t) = t
|
||||
unforall t = t
|
||||
|
||||
unforall' :: Type v a -> ([v], Type v a)
|
||||
unforall' (ForallsNamed' vs t) = (vs, t)
|
||||
unforall' t = ([], t)
|
||||
@ -458,208 +124,6 @@ dependencies t = Set.fromList . Writer.execWriter $ ABT.visit' f t
|
||||
where f t@(Ref r) = Writer.tell [r] $> t
|
||||
f t = pure t
|
||||
|
||||
updateDependencies :: Ord v => Map Reference Reference -> Type v a -> Type v a
|
||||
updateDependencies typeUpdates = ABT.rebuildUp go
|
||||
where
|
||||
go (Ref r) = Ref (Map.findWithDefault r r typeUpdates)
|
||||
go f = f
|
||||
|
||||
usesEffects :: Ord v => Type v a -> Bool
|
||||
usesEffects t = getAny . getConst $ ABT.visit go t where
|
||||
go (Effect1' _ _) = Just (Const (Any True))
|
||||
go _ = Nothing
|
||||
|
||||
-- Returns free effect variables in the given type, for instance, in:
|
||||
--
|
||||
-- ∀ e3 . a ->{e,e2} b ->{e3} c
|
||||
--
|
||||
-- This function would return the set {e, e2}, but not `e3` since `e3`
|
||||
-- is bound by the enclosing forall.
|
||||
freeEffectVars :: Ord v => Type v a -> Set v
|
||||
freeEffectVars t =
|
||||
Set.fromList . join . runIdentity $
|
||||
ABT.foreachSubterm go (snd <$> ABT.annotateBound t)
|
||||
where
|
||||
go t@(Effects' es) =
|
||||
let frees = Set.fromList [ v | Var' v <- es >>= flattenEffects ]
|
||||
in pure . Set.toList $ frees `Set.difference` ABT.annotation t
|
||||
go t@(Effect1' e _) =
|
||||
let frees = Set.fromList [ v | Var' v <- flattenEffects e ]
|
||||
in pure . Set.toList $ frees `Set.difference` ABT.annotation t
|
||||
go _ = pure []
|
||||
|
||||
-- Converts all unadorned arrows in a type to have fresh
|
||||
-- existential ability requirements. For example:
|
||||
--
|
||||
-- (a -> b) -> [a] -> [b]
|
||||
--
|
||||
-- Becomes
|
||||
--
|
||||
-- (a ->{e1} b) ->{e2} [a] ->{e3} [b]
|
||||
existentializeArrows :: (Ord v, Monad m) => m v -> Type v a -> m (Type v a)
|
||||
existentializeArrows newVar t = ABT.visit go t
|
||||
where
|
||||
go t@(Arrow' a b) = case b of
|
||||
-- If an arrow already has attached abilities,
|
||||
-- leave it alone. Ex: `a ->{e} b` is kept as is.
|
||||
Effect1' _ _ -> Just $ do
|
||||
a <- existentializeArrows newVar a
|
||||
b <- existentializeArrows newVar b
|
||||
pure $ arrow (ABT.annotation t) a b
|
||||
-- For unadorned arrows, make up a fresh variable.
|
||||
-- So `a -> b` becomes `a ->{e} b`, using the
|
||||
-- `newVar` variable generator.
|
||||
_ -> Just $ do
|
||||
e <- newVar
|
||||
a <- existentializeArrows newVar a
|
||||
b <- existentializeArrows newVar b
|
||||
let ann = ABT.annotation t
|
||||
pure $ arrow ann a (effect ann [var ann e] b)
|
||||
go _ = Nothing
|
||||
|
||||
purifyArrows :: (Ord v) => Type v a -> Type v a
|
||||
purifyArrows = ABT.visitPure go
|
||||
where
|
||||
go t@(Arrow' a b) = case b of
|
||||
Effect1' _ _ -> Nothing
|
||||
_ -> Just $ arrow ann a (effect ann [] b)
|
||||
where ann = ABT.annotation t
|
||||
go _ = Nothing
|
||||
|
||||
-- Remove free effect variables from the type that are in the set
|
||||
removeEffectVars :: ABT.Var v => Set v -> Type v a -> Type v a
|
||||
removeEffectVars removals t =
|
||||
let z = effects () []
|
||||
t' = ABT.substsInheritAnnotation ((,z) <$> Set.toList removals) t
|
||||
-- leave explicitly empty `{}` alone
|
||||
removeEmpty (Effect1' (Effects' []) v) = Just (ABT.visitPure removeEmpty v)
|
||||
removeEmpty t@(Effect1' e v) =
|
||||
case flattenEffects e of
|
||||
[] -> Just (ABT.visitPure removeEmpty v)
|
||||
es -> Just (effect (ABT.annotation t) es $ ABT.visitPure removeEmpty v)
|
||||
removeEmpty t@(Effects' es) =
|
||||
Just $ effects (ABT.annotation t) (es >>= flattenEffects)
|
||||
removeEmpty _ = Nothing
|
||||
in ABT.visitPure removeEmpty t'
|
||||
|
||||
-- Remove all effect variables from the type.
|
||||
-- Used for type-based search, we apply this transformation to both the
|
||||
-- indexed type and the query type, so the user can supply `a -> b` that will
|
||||
-- match `a ->{e} b` (but not `a ->{IO} b`).
|
||||
removeAllEffectVars :: ABT.Var v => Type v a -> Type v a
|
||||
removeAllEffectVars t = let
|
||||
allEffectVars = foldMap go (ABT.subterms t)
|
||||
go (Effects' vs) = Set.fromList [ v | Var' v <- vs]
|
||||
go (Effect1' (Var' v) _) = Set.singleton v
|
||||
go _ = mempty
|
||||
(vs, tu) = unforall' t
|
||||
in generalize vs (removeEffectVars allEffectVars tu)
|
||||
|
||||
removePureEffects :: ABT.Var v => Type v a -> Type v a
|
||||
removePureEffects t | not Settings.removePureEffects = t
|
||||
| otherwise =
|
||||
generalize vs $ removeEffectVars (Set.filter isPure fvs) tu
|
||||
where
|
||||
(vs, tu) = unforall' t
|
||||
fvs = freeEffectVars tu `Set.difference` ABT.freeVars t
|
||||
-- If an effect variable is mentioned only once, it is on
|
||||
-- an arrow `a ->{e} b`. Generalizing this to
|
||||
-- `∀ e . a ->{e} b` gives us the pure arrow `a -> b`.
|
||||
isPure v = ABT.occurrences v tu <= 1
|
||||
|
||||
editFunctionResult
|
||||
:: forall v a
|
||||
. Ord v
|
||||
=> (Type v a -> Type v a)
|
||||
-> Type v a
|
||||
-> Type v a
|
||||
editFunctionResult f = go
|
||||
where
|
||||
go :: Type v a -> Type v a
|
||||
go (ABT.Term s a t) = case t of
|
||||
ABT.Tm (Forall t) ->
|
||||
(\x -> ABT.Term (s <> freeVars x) a . ABT.Tm $ Forall x) $ go t
|
||||
ABT.Tm (Arrow i o) ->
|
||||
(\x -> ABT.Term (s <> freeVars x) a . ABT.Tm $ Arrow i x) $ go o
|
||||
ABT.Abs v r ->
|
||||
(\x -> ABT.Term (s <> freeVars x) a $ ABT.Abs v x) $ go r
|
||||
_ -> f (ABT.Term s a t)
|
||||
|
||||
functionResult :: Type v a -> Maybe (Type v a)
|
||||
functionResult = go False
|
||||
where
|
||||
go inArr (ForallNamed' _ body) = go inArr body
|
||||
go _inArr (Arrow' _i o ) = go True o
|
||||
go inArr t = if inArr then Just t else Nothing
|
||||
|
||||
|
||||
-- | Bind all free variables (not in `except`) that start with a lowercase
|
||||
-- letter and are unqualified with an outer `forall`.
|
||||
-- `a -> a` becomes `∀ a . a -> a`
|
||||
-- `B -> B` becomes `B -> B` (not changed)
|
||||
-- `.foo -> .foo` becomes `.foo -> .foo` (not changed)
|
||||
-- `.foo.bar -> blarrg.woot` becomes `.foo.bar -> blarrg.woot` (unchanged)
|
||||
generalizeLowercase :: Var v => Set v -> Type v a -> Type v a
|
||||
generalizeLowercase except t = foldr (forall (ABT.annotation t)) t vars
|
||||
where
|
||||
vars =
|
||||
[ v | v <- Set.toList (ABT.freeVars t `Set.difference` except), Var.universallyQuantifyIfFree v ]
|
||||
|
||||
-- Convert all free variables in `allowed` to variables bound by an `introOuter`.
|
||||
freeVarsToOuters :: Ord v => Set v -> Type v a -> Type v a
|
||||
freeVarsToOuters allowed t = foldr (introOuter (ABT.annotation t)) t vars
|
||||
where vars = Set.toList $ ABT.freeVars t `Set.intersection` allowed
|
||||
|
||||
-- | This function removes all variable shadowing from the types and reduces
|
||||
-- fresh ids to the minimum possible to avoid ambiguity. Useful when showing
|
||||
-- two different types.
|
||||
cleanupVars :: Var v => [Type v a] -> [Type v a]
|
||||
cleanupVars ts | not Settings.cleanupTypes = ts
|
||||
cleanupVars ts = let
|
||||
changedVars = cleanupVarsMap ts
|
||||
in cleanupVars1' changedVars <$> ts
|
||||
|
||||
-- Compute a variable replacement map from a collection of types, which
|
||||
-- can be passed to `cleanupVars1'`. This is used to cleanup variable ids
|
||||
-- for multiple related types, like when reporting a type error.
|
||||
cleanupVarsMap :: Var v => [Type v a] -> Map.Map v v
|
||||
cleanupVarsMap ts = let
|
||||
varsByName = foldl' step Map.empty (ts >>= ABT.allVars)
|
||||
step m v = Map.insertWith (++) (Var.name $ Var.reset v) [v] m
|
||||
changedVars = Map.fromList [ (v, Var.freshenId i v)
|
||||
| (_, vs) <- Map.toList varsByName
|
||||
, (v,i) <- nubOrd vs `zip` [0..]]
|
||||
in changedVars
|
||||
|
||||
cleanupVars1' :: Var v => Map.Map v v -> Type v a -> Type v a
|
||||
cleanupVars1' = ABT.changeVars
|
||||
|
||||
-- | This function removes all variable shadowing from the type and reduces
|
||||
-- fresh ids to the minimum possible to avoid ambiguity.
|
||||
cleanupVars1 :: Var v => Type v a -> Type v a
|
||||
cleanupVars1 t | not Settings.cleanupTypes = t
|
||||
cleanupVars1 t = let [t'] = cleanupVars [t] in t'
|
||||
|
||||
-- This removes duplicates and normalizes the order of ability lists
|
||||
cleanupAbilityLists :: Var v => Type v a -> Type v a
|
||||
cleanupAbilityLists = ABT.visitPure go
|
||||
where
|
||||
-- leave explicitly empty `{}` alone
|
||||
go (Effect1' (Effects' []) _v) = Nothing
|
||||
go t@(Effect1' e v) =
|
||||
let es = Set.toList . Set.fromList $ flattenEffects e
|
||||
in case es of
|
||||
[] -> Just (ABT.visitPure go v)
|
||||
_ -> Just (effect (ABT.annotation t) es $ ABT.visitPure go v)
|
||||
go _ = Nothing
|
||||
|
||||
cleanups :: Var v => [Type v a] -> [Type v a]
|
||||
cleanups ts = cleanupVars $ map cleanupAbilityLists ts
|
||||
|
||||
cleanup :: Var v => Type v a -> Type v a
|
||||
cleanup t | not Settings.cleanupTypes = t
|
||||
cleanup t = cleanupVars1 . cleanupAbilityLists $ t
|
||||
|
||||
toReference :: (ABT.Var v, Show v) => Type v a -> Reference
|
||||
toReference (Ref' r) = r
|
||||
-- a bit of normalization - any unused type parameters aren't part of the hash
|
||||
@ -672,10 +136,6 @@ toReferenceMentions ty =
|
||||
gen ty = generalize (Set.toList (freeVars ty)) $ generalize vs ty
|
||||
in Set.fromList $ toReference . gen <$> ABT.subterms ty
|
||||
|
||||
hashComponents
|
||||
:: Var v => Map v (Type v a) -> Map v (Reference.Id, Type v a)
|
||||
hashComponents = ReferenceUtil.hashComponents $ refId ()
|
||||
|
||||
instance Hashable1 F where
|
||||
hash1 hashCycle hash e =
|
||||
let
|
||||
@ -697,25 +157,3 @@ instance Hashable1 F where
|
||||
Effect e t -> [tag 5, hashed (hash e), hashed (hash t)]
|
||||
Forall a -> [tag 6, hashed (hash a)]
|
||||
IntroOuter a -> [tag 7, hashed (hash a)]
|
||||
|
||||
instance Show a => Show (F a) where
|
||||
showsPrec = go where
|
||||
go _ (Ref r) = shows r
|
||||
go p (Arrow i o) =
|
||||
showParen (p > 0) $ showsPrec (p+1) i <> s" -> " <> showsPrec p o
|
||||
go p (Ann t k) =
|
||||
showParen (p > 1) $ shows t <> s":" <> shows k
|
||||
go p (App f x) =
|
||||
showParen (p > 9) $ showsPrec 9 f <> s" " <> showsPrec 10 x
|
||||
go p (Effects es) = showParen (p > 0) $
|
||||
s"{" <> shows es <> s"}"
|
||||
go p (Effect e t) = showParen (p > 0) $
|
||||
showParen True $ shows e <> s" " <> showsPrec p t
|
||||
go p (Forall body) = case p of
|
||||
0 -> showsPrec p body
|
||||
_ -> showParen True $ s"∀ " <> shows body
|
||||
go p (IntroOuter body) = case p of
|
||||
0 -> showsPrec p body
|
||||
_ -> showParen True $ s"outer " <> shows body
|
||||
(<>) = (.)
|
||||
s = showString
|
||||
|
@ -480,12 +480,28 @@ lexemes' eof = P.optional space >> do
|
||||
local (\env -> env { inLayout = True, opening = Just "docExampleBlock" })
|
||||
(restoreStack "docExampleBlock" $ lexemes' ([] <$ lit fence))
|
||||
|
||||
uncolumn column tabWidth s =
|
||||
let
|
||||
skip col r | col < 1 = r
|
||||
skip col s@('\t' : _) | col < tabWidth = s
|
||||
skip col ('\t' : r) = skip (col - tabWidth) r
|
||||
skip col (c : r) | isSpace c && (not $ isControl c) =
|
||||
skip (col - 1) r
|
||||
skip _ s = s
|
||||
in intercalate "\n" $ skip column <$> lines s
|
||||
|
||||
other = wrap "syntax.docCodeBlock" $ do
|
||||
fence <- lit "```" <+> P.many (CP.satisfy (== '`'))
|
||||
name <- P.many (CP.satisfy nonNewlineSpace)
|
||||
*> tok (Textual <$> P.takeWhile1P Nothing (not . isSpace))
|
||||
_ <- CP.space
|
||||
verbatim <- tok $ Textual . trim <$> P.someTill CP.anyChar ([] <$ lit fence)
|
||||
column <- (\x -> x - 1) . toInteger . P.unPos <$> LP.indentLevel
|
||||
tabWidth <- toInteger . P.unPos <$> P.getTabWidth
|
||||
fence <- lit "```" <+> P.many (CP.satisfy (== '`'))
|
||||
name <-
|
||||
P.many (CP.satisfy nonNewlineSpace)
|
||||
*> tok (Textual <$> P.takeWhile1P Nothing (not . isSpace))
|
||||
<* P.many (CP.satisfy nonNewlineSpace)
|
||||
_ <- void CP.eol
|
||||
verbatim <-
|
||||
tok $ Textual . uncolumn column tabWidth . trim <$>
|
||||
P.someTill CP.anyChar ([] <$ lit fence)
|
||||
pure (name <> verbatim)
|
||||
|
||||
boldOrItalicOrStrikethrough closing = do
|
||||
|
@ -994,9 +994,6 @@ printNoteWithSource env _s (TypeInfo n) = prettyTypeInfo n env
|
||||
printNoteWithSource _env s (Parsing e) = prettyParseError s e
|
||||
printNoteWithSource env s (TypeError e) = prettyTypecheckError e env s
|
||||
printNoteWithSource _env _s (NameResolutionFailures _es) = undefined
|
||||
printNoteWithSource _env s (InvalidPath path term) =
|
||||
fromString ("Invalid Path: " ++ show path ++ "\n")
|
||||
<> annotatedAsErrorSite s term
|
||||
printNoteWithSource _env s (UnknownSymbol v a) =
|
||||
fromString ("Unknown symbol `" ++ Text.unpack (Var.name v) ++ "`\n\n")
|
||||
<> annotatedAsErrorSite s a
|
||||
|
@ -15,7 +15,6 @@ import Control.Monad.Writer ( WriterT(..)
|
||||
)
|
||||
import Unison.Name ( Name )
|
||||
import qualified Unison.Parser as Parser
|
||||
import Unison.Paths ( Path )
|
||||
import Unison.Term ( Term )
|
||||
import qualified Unison.Typechecker.Context as Context
|
||||
import Control.Error.Util ( note)
|
||||
@ -28,7 +27,6 @@ type ResultT notes f = MaybeT (WriterT notes f)
|
||||
data Note v loc
|
||||
= Parsing (Parser.Err v)
|
||||
| NameResolutionFailures [Names.ResolutionFailure v loc]
|
||||
| InvalidPath Path (Term v loc) -- todo: move me!
|
||||
| UnknownSymbol v loc
|
||||
| TypeError (Context.ErrorNote v loc)
|
||||
| TypeInfo (Context.InfoNote v loc)
|
||||
|
@ -1596,7 +1596,7 @@ declareForeigns = do
|
||||
temp <- getTemporaryDirectory
|
||||
createTempDirectory temp prefix
|
||||
|
||||
declareForeign "IO.getCurrentDirectory.impl.v3" direct
|
||||
declareForeign "IO.getCurrentDirectory.impl.v3" unitToEFBox
|
||||
. mkForeignIOF $ \() -> getCurrentDirectory
|
||||
|
||||
declareForeign "IO.setCurrentDirectory.impl.v3" boxToEF0
|
||||
|
@ -84,7 +84,7 @@ data Doc
|
||||
|
||||
type UnisonHash = Text
|
||||
|
||||
data Ref a = Term a | Type a deriving (Eq,Show,Generic,Functor,Foldable,Traversable)
|
||||
data Ref a = Term a | Type a deriving (Eq, Show, Generic, Functor, Foldable, Traversable)
|
||||
|
||||
data SpecialForm
|
||||
= Source [Ref (UnisonHash, DisplayObject SyntaxText Src)]
|
||||
@ -259,7 +259,7 @@ renderDoc pped terms typeOf eval types tm = eval tm >>= \case
|
||||
acc' = case tm of
|
||||
Term.Ref' r | Set.notMember r seen -> (:acc) . Term . (Reference.toText r,) <$> case r of
|
||||
Reference.Builtin _ -> typeOf (Referent.Ref r) <&> \case
|
||||
Nothing -> DO.BuiltinObject ("🆘 missing type signature")
|
||||
Nothing -> DO.BuiltinObject "🆘 missing type signature"
|
||||
Just ty -> DO.BuiltinObject (formatPrettyType ppe ty)
|
||||
ref -> terms ref >>= \case
|
||||
Nothing -> pure $ DO.MissingObject (SH.unsafeFromText $ Reference.toText ref)
|
||||
@ -279,4 +279,3 @@ renderDoc pped terms typeOf eval types tm = eval tm >>= \case
|
||||
-> (Set.insert ref seen,) . (:acc) <$> goType ref
|
||||
_ -> pure s1
|
||||
reverse . snd <$> foldM go mempty es
|
||||
|
||||
|
329
parser-typechecker/src/Unison/Server/Doc/AsHtml.hs
Normal file
329
parser-typechecker/src/Unison/Server/Doc/AsHtml.hs
Normal file
@ -0,0 +1,329 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
-- | Render Unison.Server.Doc and embedded source to Html
|
||||
module Unison.Server.Doc.AsHtml where
|
||||
|
||||
import Data.Foldable
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Lucid
|
||||
import qualified Lucid as L
|
||||
import Unison.Codebase.Editor.DisplayObject (DisplayObject (..))
|
||||
import Unison.Server.Doc
|
||||
import Unison.Server.Syntax (SyntaxText)
|
||||
import qualified Unison.Server.Syntax as Syntax
|
||||
|
||||
data NamedLinkHref
|
||||
= Href Text
|
||||
| ReferenceHref Text
|
||||
| InvalidHref
|
||||
|
||||
data EmbeddedSource
|
||||
= EmbeddedSource SyntaxText SyntaxText
|
||||
| Builtin SyntaxText
|
||||
|
||||
embeddedSource :: Ref (UnisonHash, DisplayObject SyntaxText Src) -> Maybe EmbeddedSource
|
||||
embeddedSource ref =
|
||||
let embeddedSource' (_, displayObj) =
|
||||
case displayObj of
|
||||
BuiltinObject s -> Just (Builtin s)
|
||||
UserObject (Src sum det) -> Just (EmbeddedSource sum det)
|
||||
MissingObject _ -> Nothing
|
||||
in case ref of
|
||||
Term s -> embeddedSource' s
|
||||
Type s -> embeddedSource' s
|
||||
|
||||
inlineCode :: [Attribute] -> Html () -> Html ()
|
||||
inlineCode attrs =
|
||||
pre_ (class_ "inline-code" : attrs) . code_ []
|
||||
|
||||
codeBlock :: [Attribute] -> Html () -> Html ()
|
||||
codeBlock attrs =
|
||||
pre_ attrs . code_ []
|
||||
|
||||
normalizeHref :: NamedLinkHref -> Doc -> NamedLinkHref
|
||||
normalizeHref href doc =
|
||||
case doc of
|
||||
Word w ->
|
||||
case href of
|
||||
InvalidHref ->
|
||||
Href w
|
||||
Href h ->
|
||||
Href (h <> w)
|
||||
ReferenceHref _ ->
|
||||
href
|
||||
Group d_ ->
|
||||
normalizeHref href d_
|
||||
Join ds ->
|
||||
foldl' normalizeHref href ds
|
||||
Special (Link syntax) ->
|
||||
maybe InvalidHref ReferenceHref (Syntax.firstReference syntax)
|
||||
_ ->
|
||||
href
|
||||
|
||||
data IsFolded
|
||||
= IsFolded Bool [Html ()] [Html ()]
|
||||
| Disabled (Html ())
|
||||
|
||||
foldedToHtml :: [Attribute] -> IsFolded -> Html ()
|
||||
foldedToHtml attrs isFolded =
|
||||
case isFolded of
|
||||
Disabled summary ->
|
||||
details_ attrs $ summary_ summary
|
||||
IsFolded isFolded summary details ->
|
||||
let attrsWithOpen =
|
||||
if isFolded
|
||||
then open_ "open" : attrs
|
||||
else attrs
|
||||
in details_ attrsWithOpen $ summary_ [] $ sequence_ $ summary ++ details
|
||||
|
||||
foldedToHtmlSource :: Bool -> EmbeddedSource -> Html ()
|
||||
foldedToHtmlSource isFolded source =
|
||||
case source of
|
||||
Builtin summary ->
|
||||
foldedToHtml
|
||||
[class_ "rich source"]
|
||||
( Disabled
|
||||
( div_
|
||||
[class_ "builtin-summary"]
|
||||
$ do
|
||||
codeBlock [] $ Syntax.toHtml summary
|
||||
badge $ do
|
||||
span_ [] $ strong_ [] "Built-in"
|
||||
span_ [] "provided by the Unison runtime"
|
||||
)
|
||||
)
|
||||
EmbeddedSource summary details ->
|
||||
foldedToHtml [class_ "rich source"] $
|
||||
IsFolded
|
||||
isFolded
|
||||
[codeBlock [] $ Syntax.toHtml summary]
|
||||
[codeBlock [] $ Syntax.toHtml details]
|
||||
|
||||
-- | Merge adjacent Word elements in a list to 1 element with a string of words
|
||||
-- separated by space— useful for rendering to the dom without creating dom
|
||||
-- elements for each and every word in the doc, but instead rely on textNodes
|
||||
mergeWords :: [Doc] -> [Doc]
|
||||
mergeWords = foldr merge_ []
|
||||
where
|
||||
merge_ :: Doc -> [Doc] -> [Doc]
|
||||
merge_ d acc =
|
||||
case (d, acc) of
|
||||
(Word w, Word w_ : rest) ->
|
||||
Word (w <> " " <> w_) : rest
|
||||
_ ->
|
||||
d : acc
|
||||
|
||||
toHtml :: Doc -> Html ()
|
||||
toHtml document =
|
||||
let toHtml_ sectionLevel doc =
|
||||
let -- Make it simple to retain the sectionLevel when recurring.
|
||||
-- the Section variant increments it locally
|
||||
currentSectionLevelToHtml =
|
||||
toHtml_ sectionLevel
|
||||
|
||||
sectionContentToHtml renderer doc_ =
|
||||
case doc_ of
|
||||
Paragraph _ ->
|
||||
p_ [] $ renderer doc_
|
||||
_ ->
|
||||
renderer doc_
|
||||
in case doc of
|
||||
Word word ->
|
||||
span_ [class_ "word"] (L.toHtml word)
|
||||
Code code ->
|
||||
span_ [class_ "rich source inline-code"] $ inlineCode [] (currentSectionLevelToHtml code)
|
||||
CodeBlock lang code ->
|
||||
div_ [class_ "rich source code", class_ $ textToClass lang] $ codeBlock [] (currentSectionLevelToHtml code)
|
||||
Bold d ->
|
||||
strong_ [] $ currentSectionLevelToHtml d
|
||||
Italic d ->
|
||||
span_ [class_ "italic"] $ currentSectionLevelToHtml d
|
||||
Strikethrough d ->
|
||||
span_ [class_ "strikethrough"] $ currentSectionLevelToHtml d
|
||||
Style cssclass_ d ->
|
||||
span_ [class_ $ textToClass cssclass_] $ currentSectionLevelToHtml d
|
||||
Anchor id' d ->
|
||||
a_ [id_ id', target_ id'] $ currentSectionLevelToHtml d
|
||||
Blockquote d ->
|
||||
blockquote_ [] $ currentSectionLevelToHtml d
|
||||
Blankline ->
|
||||
div_ [] $ do
|
||||
br_ []
|
||||
br_ []
|
||||
Linebreak ->
|
||||
br_ []
|
||||
SectionBreak ->
|
||||
hr_ []
|
||||
Tooltip triggerContent tooltipContent ->
|
||||
span_
|
||||
[class_ "tooltip below arrow-start"]
|
||||
$ do
|
||||
span_ [class_ "tooltip-trigger"] $ currentSectionLevelToHtml triggerContent
|
||||
div_ [class_ "tooltip-bubble", style_ "display: none"] $ currentSectionLevelToHtml tooltipContent
|
||||
Aside d ->
|
||||
span_
|
||||
[class_ "aside-anchor"]
|
||||
$ aside_ [] $ currentSectionLevelToHtml d
|
||||
Callout icon content ->
|
||||
let (cls, ico) =
|
||||
case icon of
|
||||
Just (Word emoji) ->
|
||||
(class_ "callout callout-with-icon", div_ [class_ "callout-icon"] $ L.toHtml emoji)
|
||||
_ ->
|
||||
(class_ "callout", "")
|
||||
in div_ [cls] $ do
|
||||
ico
|
||||
div_ [class_ "callout-content"] $ currentSectionLevelToHtml content
|
||||
Table rows ->
|
||||
let cellToHtml =
|
||||
td_ [] . currentSectionLevelToHtml
|
||||
|
||||
rowToHtml cells =
|
||||
tr_ [] $ mapM_ cellToHtml $ mergeWords cells
|
||||
in table_ [] $ tbody_ [] $ mapM_ rowToHtml rows
|
||||
Folded isFolded summary details ->
|
||||
let content =
|
||||
if isFolded
|
||||
then [currentSectionLevelToHtml summary]
|
||||
else
|
||||
[ currentSectionLevelToHtml summary,
|
||||
currentSectionLevelToHtml details
|
||||
]
|
||||
in foldedToHtml [] (IsFolded isFolded content [])
|
||||
Paragraph docs ->
|
||||
case docs of
|
||||
[d] ->
|
||||
currentSectionLevelToHtml d
|
||||
ds ->
|
||||
span_ [class_ "span"] $ mapM_ currentSectionLevelToHtml $ mergeWords ds
|
||||
BulletedList items ->
|
||||
let itemToHtml =
|
||||
li_ [] . currentSectionLevelToHtml
|
||||
in ul_ [] $ mapM_ itemToHtml $ mergeWords items
|
||||
NumberedList startNum items ->
|
||||
let itemToHtml =
|
||||
li_ [] . currentSectionLevelToHtml
|
||||
in ol_ [start_ $ Text.pack $ show startNum] $ mapM_ itemToHtml $ mergeWords items
|
||||
Section title docs ->
|
||||
let titleEl =
|
||||
h sectionLevel $ currentSectionLevelToHtml title
|
||||
in section_ [] $ sequence_ (titleEl : map (sectionContentToHtml (toHtml_ (sectionLevel + 1))) docs)
|
||||
NamedLink label href ->
|
||||
case normalizeHref InvalidHref href of
|
||||
Href h ->
|
||||
a_ [class_ "named-link", href_ h, rel_ "noopener", target_ "_blank"] $ currentSectionLevelToHtml label
|
||||
ReferenceHref ref ->
|
||||
a_ [class_ "named-link", data_ "ref" ref] $ currentSectionLevelToHtml label
|
||||
InvalidHref ->
|
||||
span_ [class_ "named-link invalid-href"] $ currentSectionLevelToHtml label
|
||||
Image altText src caption ->
|
||||
let altAttr =
|
||||
case altText of
|
||||
Word t ->
|
||||
[alt_ t]
|
||||
_ ->
|
||||
[]
|
||||
|
||||
image =
|
||||
case src of
|
||||
Word s ->
|
||||
img_ (altAttr ++ [src_ s])
|
||||
_ ->
|
||||
""
|
||||
|
||||
imageWithCaption c =
|
||||
div_
|
||||
[class_ "image-with-caption"]
|
||||
$ do
|
||||
image
|
||||
div_ [class_ "caption"] $ currentSectionLevelToHtml c
|
||||
in maybe image imageWithCaption caption
|
||||
Special specialForm ->
|
||||
case specialForm of
|
||||
Source sources ->
|
||||
let sources' =
|
||||
mapMaybe
|
||||
(fmap (foldedToHtmlSource False) . embeddedSource)
|
||||
sources
|
||||
in div_ [class_ "folded-sources"] $ sequence_ sources'
|
||||
FoldedSource sources ->
|
||||
let sources' =
|
||||
mapMaybe
|
||||
(fmap (foldedToHtmlSource True) . embeddedSource)
|
||||
sources
|
||||
in div_ [class_ "folded-sources"] $ sequence_ sources'
|
||||
Example syntax ->
|
||||
span_ [class_ "source rich example-inline"] $ inlineCode [] (Syntax.toHtml syntax)
|
||||
ExampleBlock syntax ->
|
||||
div_ [class_ "source rich example"] $ codeBlock [] (Syntax.toHtml syntax)
|
||||
Link syntax ->
|
||||
inlineCode [class_ "rich source"] (Syntax.toHtml syntax)
|
||||
Signature signatures ->
|
||||
div_
|
||||
[class_ "rich source signatures"]
|
||||
( mapM_
|
||||
(div_ [class_ "signature"] . Syntax.toHtml)
|
||||
signatures
|
||||
)
|
||||
SignatureInline sig ->
|
||||
span_ [class_ "rich source signature-inline"] $ Syntax.toHtml sig
|
||||
Eval source result ->
|
||||
div_ [class_ "source rich eval"] $
|
||||
codeBlock [] $
|
||||
div_ [] $ do
|
||||
Syntax.toHtml source
|
||||
div_ [class_ "result"] $ do
|
||||
"⧨"
|
||||
div_ [] $ Syntax.toHtml result
|
||||
EvalInline source result ->
|
||||
span_ [class_ "source rich eval-inline"] $
|
||||
inlineCode [] $
|
||||
span_ [] $ do
|
||||
Syntax.toHtml source
|
||||
span_ [class_ "result"] $ do
|
||||
"⧨"
|
||||
Syntax.toHtml result
|
||||
Embed syntax ->
|
||||
div_ [class_ "source rich embed"] $ codeBlock [] (Syntax.toHtml syntax)
|
||||
EmbedInline syntax ->
|
||||
span_ [class_ "source rich embed-inline"] $ inlineCode [] (Syntax.toHtml syntax)
|
||||
Join docs ->
|
||||
span_ [class_ "join"] (mapM_ currentSectionLevelToHtml (mergeWords docs))
|
||||
UntitledSection docs ->
|
||||
section_ [] (mapM_ (sectionContentToHtml currentSectionLevelToHtml) docs)
|
||||
Column docs ->
|
||||
ul_
|
||||
[class_ "column"]
|
||||
( mapM_
|
||||
(li_ [] . currentSectionLevelToHtml)
|
||||
(mergeWords docs)
|
||||
)
|
||||
Group content ->
|
||||
span_ [class_ "group"] $ currentSectionLevelToHtml content
|
||||
in article_ [class_ "unison-doc"] $ toHtml_ 1 document
|
||||
|
||||
-- HELPERS --------------------------------------------------------------------
|
||||
|
||||
-- | Unison Doc allows endlessly deep section nesting with
|
||||
-- titles, but HTML only supports to h1-h6, so we clamp
|
||||
-- the sectionLevel when converting
|
||||
h :: Nat -> (Html () -> Html ())
|
||||
h n =
|
||||
case n of
|
||||
1 -> h1_
|
||||
2 -> h2_
|
||||
3 -> h3_
|
||||
4 -> h4_
|
||||
5 -> h5_
|
||||
6 -> h6_
|
||||
_ -> h6_
|
||||
|
||||
badge :: Html () -> Html ()
|
||||
badge =
|
||||
span_ [class_ "badge"]
|
||||
|
||||
textToClass :: Text -> Text
|
||||
textToClass =
|
||||
Text.replace " " "__"
|
@ -1,33 +1,45 @@
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
-- Duplicate of the Unison.Util.SyntaxText module, but we expect these to
|
||||
-- | Duplicate of the Unison.Util.SyntaxText module, but we expect these to
|
||||
-- evolve separately. This is the version which is outward facing
|
||||
-- to the server frontend.
|
||||
module Unison.Server.Syntax where
|
||||
|
||||
import Data.Aeson ( ToJSON )
|
||||
import Data.OpenApi ( ToSchema(..) )
|
||||
import Unison.Prelude
|
||||
import qualified Unison.HashQualified as HashQualified
|
||||
import Unison.Pattern ( SeqOp(..) )
|
||||
|
||||
import Unison.Util.AnnotatedText ( AnnotatedText(..)
|
||||
, Segment(..)
|
||||
, annotate
|
||||
, segment
|
||||
)
|
||||
import qualified Unison.Util.SyntaxText as SyntaxText
|
||||
import Unison.Reference ( Reference )
|
||||
import qualified Unison.Reference as Reference
|
||||
import qualified Unison.Referent as Referent
|
||||
import Data.Proxy ( Proxy(..) )
|
||||
import Data.Aeson (ToJSON)
|
||||
import qualified Data.List as List
|
||||
import qualified Data.List.NonEmpty as List.NonEmpty
|
||||
import Data.OpenApi (ToSchema (..))
|
||||
import Data.Proxy (Proxy (..))
|
||||
import qualified Data.Text as Text
|
||||
import Lucid
|
||||
import qualified Lucid as L
|
||||
import qualified Unison.HashQualified as HashQualified
|
||||
import Unison.Name (Name)
|
||||
import qualified Unison.Name as Name
|
||||
import qualified Unison.NameSegment as NameSegment
|
||||
import Unison.Pattern (SeqOp (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Reference (Reference)
|
||||
import qualified Unison.Reference as Reference
|
||||
import qualified Unison.Referent as Referent
|
||||
import Unison.Util.AnnotatedText
|
||||
( AnnotatedText (..),
|
||||
Segment (..),
|
||||
annotate,
|
||||
segment,
|
||||
)
|
||||
import qualified Unison.Util.SyntaxText as SyntaxText
|
||||
import Data.List.Extra
|
||||
|
||||
type SyntaxText = AnnotatedText Element
|
||||
|
||||
type SyntaxSegment = Segment Element
|
||||
|
||||
instance ToJSON Element
|
||||
|
||||
deriving instance ToSchema Element
|
||||
@ -49,88 +61,248 @@ instance ToSchema r => ToSchema (Seq r) where
|
||||
|
||||
convertElement :: SyntaxText.Element Reference -> Element
|
||||
convertElement = \case
|
||||
SyntaxText.NumericLiteral -> NumericLiteral
|
||||
SyntaxText.TextLiteral -> TextLiteral
|
||||
SyntaxText.BytesLiteral -> BytesLiteral
|
||||
SyntaxText.CharLiteral -> CharLiteral
|
||||
SyntaxText.BooleanLiteral -> BooleanLiteral
|
||||
SyntaxText.Blank -> Blank
|
||||
SyntaxText.Var -> Var
|
||||
SyntaxText.Referent r -> TermReference $ Referent.toText r
|
||||
SyntaxText.Reference r -> TypeReference $ Reference.toText r
|
||||
SyntaxText.Op s -> Op s
|
||||
SyntaxText.AbilityBraces -> AbilityBraces
|
||||
SyntaxText.ControlKeyword -> ControlKeyword
|
||||
SyntaxText.TypeOperator -> TypeOperator
|
||||
SyntaxText.BindingEquals -> BindingEquals
|
||||
SyntaxText.NumericLiteral -> NumericLiteral
|
||||
SyntaxText.TextLiteral -> TextLiteral
|
||||
SyntaxText.BytesLiteral -> BytesLiteral
|
||||
SyntaxText.CharLiteral -> CharLiteral
|
||||
SyntaxText.BooleanLiteral -> BooleanLiteral
|
||||
SyntaxText.Blank -> Blank
|
||||
SyntaxText.Var -> Var
|
||||
SyntaxText.Referent r -> TermReference $ Referent.toText r
|
||||
SyntaxText.Reference r -> TypeReference $ Reference.toText r
|
||||
SyntaxText.Op s -> Op s
|
||||
SyntaxText.AbilityBraces -> AbilityBraces
|
||||
SyntaxText.ControlKeyword -> ControlKeyword
|
||||
SyntaxText.TypeOperator -> TypeOperator
|
||||
SyntaxText.BindingEquals -> BindingEquals
|
||||
SyntaxText.TypeAscriptionColon -> TypeAscriptionColon
|
||||
SyntaxText.DataTypeKeyword -> DataTypeKeyword
|
||||
SyntaxText.DataTypeParams -> DataTypeParams
|
||||
SyntaxText.Unit -> Unit
|
||||
SyntaxText.DataTypeModifier -> DataTypeModifier
|
||||
SyntaxText.UseKeyword -> UseKeyword
|
||||
SyntaxText.UsePrefix -> UsePrefix
|
||||
SyntaxText.UseSuffix -> UseSuffix
|
||||
SyntaxText.HashQualifier n -> HashQualifier (HashQualified.toText n)
|
||||
SyntaxText.DelayForceChar -> DelayForceChar
|
||||
SyntaxText.DelimiterChar -> DelimiterChar
|
||||
SyntaxText.Parenthesis -> Parenthesis
|
||||
SyntaxText.LinkKeyword -> LinkKeyword
|
||||
SyntaxText.DocDelimiter -> DocDelimiter
|
||||
SyntaxText.DocKeyword -> DocKeyword
|
||||
SyntaxText.DataTypeKeyword -> DataTypeKeyword
|
||||
SyntaxText.DataTypeParams -> DataTypeParams
|
||||
SyntaxText.Unit -> Unit
|
||||
SyntaxText.DataTypeModifier -> DataTypeModifier
|
||||
SyntaxText.UseKeyword -> UseKeyword
|
||||
SyntaxText.UsePrefix -> UsePrefix
|
||||
SyntaxText.UseSuffix -> UseSuffix
|
||||
SyntaxText.HashQualifier n -> HashQualifier (HashQualified.toText n)
|
||||
SyntaxText.DelayForceChar -> DelayForceChar
|
||||
SyntaxText.DelimiterChar -> DelimiterChar
|
||||
SyntaxText.Parenthesis -> Parenthesis
|
||||
SyntaxText.LinkKeyword -> LinkKeyword
|
||||
SyntaxText.DocDelimiter -> DocDelimiter
|
||||
SyntaxText.DocKeyword -> DocKeyword
|
||||
|
||||
type UnisonHash = Text
|
||||
|
||||
type HashQualifiedName = Text
|
||||
|
||||
-- The elements of the Unison grammar, for syntax highlighting purposes
|
||||
data Element = NumericLiteral
|
||||
| TextLiteral
|
||||
| BytesLiteral
|
||||
| CharLiteral
|
||||
| BooleanLiteral
|
||||
| Blank
|
||||
| Var
|
||||
| TypeReference UnisonHash
|
||||
| TermReference UnisonHash
|
||||
| Op SeqOp
|
||||
| Constructor
|
||||
| Request
|
||||
| AbilityBraces
|
||||
-- let|handle|in|where|match|with|cases|->|if|then|else|and|or
|
||||
| ControlKeyword
|
||||
-- forall|->
|
||||
| TypeOperator
|
||||
| BindingEquals
|
||||
| TypeAscriptionColon
|
||||
-- type|ability
|
||||
| DataTypeKeyword
|
||||
| DataTypeParams
|
||||
| Unit
|
||||
-- unique
|
||||
| DataTypeModifier
|
||||
-- `use Foo bar` is keyword, prefix, suffix
|
||||
| UseKeyword
|
||||
| UsePrefix
|
||||
| UseSuffix
|
||||
| HashQualifier HashQualifiedName
|
||||
| DelayForceChar
|
||||
-- ? , ` [ ] @ |
|
||||
-- Currently not all commas in the pretty-print output are marked up as DelimiterChar - we miss
|
||||
-- out characters emitted by Pretty.hs helpers like Pretty.commas.
|
||||
| DelimiterChar
|
||||
-- ! '
|
||||
| Parenthesis
|
||||
| LinkKeyword -- `typeLink` and `termLink`
|
||||
-- [: :] @[]
|
||||
| DocDelimiter
|
||||
-- the 'include' in @[include], etc
|
||||
| DocKeyword
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
-- | The elements of the Unison grammar, for syntax highlighting purposes
|
||||
data Element
|
||||
= NumericLiteral
|
||||
| TextLiteral
|
||||
| BytesLiteral
|
||||
| CharLiteral
|
||||
| BooleanLiteral
|
||||
| Blank
|
||||
| Var
|
||||
| TypeReference UnisonHash
|
||||
| DataConstructorReference UnisonHash
|
||||
| AbilityConstructorReference UnisonHash
|
||||
| TermReference UnisonHash
|
||||
| Op SeqOp
|
||||
| -- | Constructor Are these even used?
|
||||
-- | Request
|
||||
AbilityBraces
|
||||
| -- let|handle|in|where|match|with|cases|->|if|then|else|and|or
|
||||
ControlKeyword
|
||||
| -- forall|->
|
||||
TypeOperator
|
||||
| BindingEquals
|
||||
| TypeAscriptionColon
|
||||
| -- type|ability
|
||||
DataTypeKeyword
|
||||
| DataTypeParams
|
||||
| Unit
|
||||
| -- unique
|
||||
DataTypeModifier
|
||||
| -- `use Foo bar` is keyword, prefix, suffix
|
||||
UseKeyword
|
||||
| UsePrefix
|
||||
| UseSuffix
|
||||
| HashQualifier HashQualifiedName
|
||||
| DelayForceChar
|
||||
| -- ? , ` [ ] @ |
|
||||
-- Currently not all commas in the pretty-print output are marked up as DelimiterChar - we miss
|
||||
-- out characters emitted by Pretty.hs helpers like Pretty.commas.
|
||||
DelimiterChar
|
||||
| -- ! '
|
||||
Parenthesis
|
||||
| LinkKeyword -- `typeLink` and `termLink`
|
||||
-- [: :] @[]
|
||||
| DocDelimiter
|
||||
| -- the 'include' in @[include], etc
|
||||
DocKeyword
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
|
||||
syntax :: Element -> SyntaxText -> SyntaxText
|
||||
syntax = annotate
|
||||
|
||||
-- Convert a `SyntaxText` to a `String`, ignoring syntax markup
|
||||
firstReference :: SyntaxText -> Maybe UnisonHash
|
||||
firstReference (AnnotatedText segments) =
|
||||
firstJust reference (toList segments)
|
||||
|
||||
reference :: SyntaxSegment -> Maybe UnisonHash
|
||||
reference (Segment _ el) =
|
||||
let reference' el' =
|
||||
case el' of
|
||||
TermReference r -> Just r
|
||||
TypeReference r -> Just r
|
||||
_ -> Nothing
|
||||
in el >>= reference'
|
||||
|
||||
-- | Convert a `SyntaxText` to a `String`, ignoring syntax markup
|
||||
toPlain :: SyntaxText -> String
|
||||
toPlain (AnnotatedText at) = join (toList $ segment <$> at)
|
||||
|
||||
-- HTML -----------------------------------------------------------------------
|
||||
|
||||
toHtml :: SyntaxText -> Html ()
|
||||
toHtml (AnnotatedText segments) =
|
||||
let renderedSegments =
|
||||
fmap segmentToHtml segments
|
||||
in span_ [class_ "syntax"] $ sequence_ (toList renderedSegments)
|
||||
|
||||
nameToHtml :: Name -> Html ()
|
||||
nameToHtml name =
|
||||
span_ [class_ "fqn"] $ sequence_ parts
|
||||
where
|
||||
segments =
|
||||
map (segment . L.toHtml . NameSegment.toText) $ List.NonEmpty.toList $ Name.segments name
|
||||
|
||||
segment =
|
||||
span_ [class_ "segment"]
|
||||
|
||||
sep =
|
||||
span_ [class_ "sep "] "."
|
||||
|
||||
parts =
|
||||
List.intersperse sep segments
|
||||
|
||||
segmentToHtml :: SyntaxSegment -> Html ()
|
||||
segmentToHtml (Segment segmentText element) =
|
||||
let sText = Text.pack segmentText
|
||||
|
||||
el = fromMaybe Blank element
|
||||
|
||||
ref =
|
||||
case el of
|
||||
TypeReference h ->
|
||||
Just h
|
||||
TermReference h ->
|
||||
Just h
|
||||
AbilityConstructorReference h ->
|
||||
Just h
|
||||
DataConstructorReference h ->
|
||||
Just h
|
||||
_ ->
|
||||
Nothing
|
||||
|
||||
isFQN =
|
||||
let isFQN_ =
|
||||
Text.isInfixOf "." sText
|
||||
in case el of
|
||||
TypeReference {} ->
|
||||
isFQN_
|
||||
TermReference {} ->
|
||||
isFQN_
|
||||
HashQualifier {} ->
|
||||
isFQN_
|
||||
DataConstructorReference {} ->
|
||||
isFQN_
|
||||
AbilityConstructorReference {} ->
|
||||
isFQN_
|
||||
_ ->
|
||||
False
|
||||
|
||||
className =
|
||||
elementToClassName el
|
||||
|
||||
content
|
||||
| Text.isInfixOf "->" sText = span_ [class_ "arrow"] $ L.toHtml sText
|
||||
| isFQN = nameToHtml (Name.unsafeFromText sText)
|
||||
| otherwise = L.toHtml sText
|
||||
in case ref of
|
||||
Just r ->
|
||||
span_ [class_ className, data_ "ref" r] content
|
||||
_ ->
|
||||
span_ [class_ className] content
|
||||
|
||||
elementToClassName :: Element -> Text
|
||||
elementToClassName el =
|
||||
case el of
|
||||
NumericLiteral ->
|
||||
"numeric-literal"
|
||||
TextLiteral ->
|
||||
"text-literal"
|
||||
BytesLiteral ->
|
||||
"bytes-literal"
|
||||
CharLiteral ->
|
||||
"char-literal"
|
||||
BooleanLiteral ->
|
||||
"boolean-literal"
|
||||
Blank ->
|
||||
"blank"
|
||||
Var ->
|
||||
"var"
|
||||
TypeReference {} ->
|
||||
"type-reference"
|
||||
TermReference {} ->
|
||||
"term-reference"
|
||||
DataConstructorReference {} ->
|
||||
"data-constructor-reference"
|
||||
AbilityConstructorReference {} ->
|
||||
"ability-constructor-reference"
|
||||
Op seqOp ->
|
||||
case seqOp of
|
||||
Cons ->
|
||||
"op cons"
|
||||
Snoc ->
|
||||
"op snoc"
|
||||
Concat ->
|
||||
"op concat"
|
||||
AbilityBraces ->
|
||||
"ability-braces"
|
||||
ControlKeyword ->
|
||||
"control-keyword"
|
||||
TypeOperator ->
|
||||
"type-operator"
|
||||
BindingEquals ->
|
||||
"binding-equals"
|
||||
TypeAscriptionColon ->
|
||||
"type-ascription-colon"
|
||||
DataTypeKeyword -> "data-type-keyword"
|
||||
DataTypeParams ->
|
||||
"data-type-params"
|
||||
Unit ->
|
||||
"unit"
|
||||
DataTypeModifier ->
|
||||
"data-type-modifier"
|
||||
UseKeyword ->
|
||||
"use-keyword"
|
||||
UsePrefix ->
|
||||
"use-prefix"
|
||||
UseSuffix ->
|
||||
"use-suffix"
|
||||
HashQualifier {} ->
|
||||
"hash-qualifier"
|
||||
DelayForceChar ->
|
||||
"delay-force-char"
|
||||
DelimiterChar ->
|
||||
"delimeter-char"
|
||||
Parenthesis ->
|
||||
"parenthesis"
|
||||
LinkKeyword ->
|
||||
"link-keyword"
|
||||
DocDelimiter ->
|
||||
"doc-delimeter"
|
||||
DocKeyword ->
|
||||
"doc-keyword"
|
||||
|
@ -74,70 +74,6 @@ data Env v loc = Env
|
||||
|
||||
makeLenses ''Env
|
||||
|
||||
-- -- | Compute the allowed type of a replacement for a given subterm.
|
||||
-- -- Example, in @\g -> map g [1,2,3]@, @g@ has an admissible type of
|
||||
-- -- @Int -> r@, where @r@ is an unbound universal type variable, which
|
||||
-- -- means that an @Int -> Bool@, an @Int -> String@, etc could all be
|
||||
-- -- substituted for @g@.
|
||||
-- --
|
||||
-- -- Algorithm works by replacing the subterm, @e@ with
|
||||
-- -- @(f e)@, where @f@ is a fresh function parameter. We then
|
||||
-- -- read off the type of @e@ from the inferred result type of @f@.
|
||||
-- admissibleTypeAt :: (Monad f, Var v)
|
||||
-- => (Env v loc)
|
||||
-- -> Path
|
||||
-- -> Term v loc
|
||||
-- -> f (Result v loc (Type v loc))
|
||||
-- admissibleTypeAt env path t =
|
||||
-- let
|
||||
-- f = ABT.v' "f"
|
||||
-- shake (Type.Arrow' (Type.Arrow' _ tsub) _) = Type.generalize tsub
|
||||
-- shake (Type.ForallNamed' _ t) = shake t
|
||||
-- shake _ = error "impossible, f had better be a function"
|
||||
-- in case Term.lam() f <$> Paths.modifyTerm (\t -> Term.app() (Term.var() (ABT.Free f)) (Term.wrapV t)) path t of
|
||||
-- Nothing -> pure . failNote $ InvalidPath path t
|
||||
-- Just t -> fmap shake <$> synthesize env t
|
||||
|
||||
-- -- | Compute the type of the given subterm.
|
||||
-- typeAt :: (Monad f, Var v) => Env v loc -> Path -> Term v loc -> f (Type v loc)
|
||||
-- typeAt env [] t = synthesize env t
|
||||
-- typeAt env path t =
|
||||
-- let
|
||||
-- f = ABT.v' "f"
|
||||
-- remember e = Term.var() (ABT.Free f) `Term.app_` Term.wrapV e
|
||||
-- shake (Type.Arrow' (Type.Arrow' tsub _) _) = Type.generalize tsub
|
||||
-- shake (Type.ForallNamed' _ t) = shake t
|
||||
-- shake _ = error "impossible, f had better be a function"
|
||||
-- in case Term.lam() f <$> Paths.modifyTerm remember path t of
|
||||
-- Nothing -> failNote $ InvalidPath path t
|
||||
-- Just t -> pure . shake <$> synthesize env t
|
||||
--
|
||||
-- -- | Return the type of all local variables in scope at the given location
|
||||
-- locals :: (Monad f, Var v) => Env v loc -> Path -> Term v loc
|
||||
-- -> f [(v, Type v loc)]
|
||||
-- locals env path ctx | ABT.isClosed ctx =
|
||||
-- zip (map ABT.unvar vars) <$> types
|
||||
-- where
|
||||
-- -- replace focus, x, with `let saved = f v1 v2 v3 ... vn in x`,
|
||||
-- -- where `f` is fresh variable, then infer type of `f`, read off the
|
||||
-- -- types of `v1`, `v2`, ...
|
||||
-- vars = map ABT.Bound (Paths.inScopeAtTerm path ctx)
|
||||
-- f = ABT.v' "f"
|
||||
-- saved = ABT.v' "saved"
|
||||
-- remember e = Term.let1_ [(saved, Term.var() (ABT.Free f) `Term.apps` map (((),) . Term.var()) vars)] (Term.wrapV e)
|
||||
-- usingAllLocals = Term.lam() f (Paths.modifyTerm' remember path ctx)
|
||||
-- types = if null vars then pure []
|
||||
-- else extract <$> typeAt env [] usingAllLocals
|
||||
-- extract (Type.Arrow' i _) = extract1 i
|
||||
-- extract (Type.ForallNamed' _ t) = extract t
|
||||
-- extract t = error $ "expected function type, got: " ++ show t
|
||||
-- extract1 (Type.Arrow' i o) = i : extract1 o
|
||||
-- extract1 _ = []
|
||||
-- locals _ _ _ _ ctx =
|
||||
-- -- need to call failNote multiple times
|
||||
-- failNote <$> (uncurry UnknownSymbol <$> ABT.freeVarAnnotations ctx)
|
||||
|
||||
|
||||
-- | Infer the type of a 'Unison.Term', using
|
||||
-- a function to resolve the type of @Ref@ constructors
|
||||
-- contained in that term.
|
||||
|
@ -139,6 +139,7 @@ library
|
||||
Unison.Server.Backend
|
||||
Unison.Server.CodebaseServer
|
||||
Unison.Server.Doc
|
||||
Unison.Server.Doc.AsHtml
|
||||
Unison.Server.Endpoints.FuzzyFind
|
||||
Unison.Server.Endpoints.GetDefinitions
|
||||
Unison.Server.Endpoints.NamespaceDetails
|
||||
@ -246,6 +247,7 @@ library
|
||||
, http-media
|
||||
, http-types
|
||||
, lens
|
||||
, lucid
|
||||
, megaparsec >=5.0.0 && <7.0.0
|
||||
, memory
|
||||
, mmorph
|
||||
|
@ -13,7 +13,7 @@ packages:
|
||||
- yaks/easytest
|
||||
- parser-typechecker
|
||||
- unison-core
|
||||
- cli
|
||||
- unison-cli
|
||||
- codebase2/codebase
|
||||
- codebase2/codebase-sqlite
|
||||
- codebase2/codebase-sync
|
||||
|
@ -5,20 +5,93 @@
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
|
||||
module Unison.ABT where
|
||||
module Unison.ABT
|
||||
( -- * Types
|
||||
ABT(..)
|
||||
, Term(..)
|
||||
, Var(..)
|
||||
|
||||
, V(..)
|
||||
, Subst(..)
|
||||
|
||||
-- * Combinators & Traversals
|
||||
, fresh
|
||||
, unvar
|
||||
, freshenS
|
||||
, freshInBoth
|
||||
, visit
|
||||
, visit'
|
||||
, visitPure
|
||||
, changeVars
|
||||
, allVars
|
||||
, subterms
|
||||
, annotateBound
|
||||
, rebuildUp
|
||||
, rebuildUp'
|
||||
, reannotateUp
|
||||
, rewriteDown
|
||||
, transform
|
||||
, transformM
|
||||
, foreachSubterm
|
||||
, freeVarOccurrences
|
||||
, isFreeIn
|
||||
, occurrences
|
||||
, extraMap
|
||||
, vmap
|
||||
, vmapM
|
||||
, amap
|
||||
, rename
|
||||
, renames
|
||||
, subst
|
||||
, substs
|
||||
, substInheritAnnotation
|
||||
, substsInheritAnnotation
|
||||
, find
|
||||
, find'
|
||||
, FindAction(..)
|
||||
|
||||
-- * Safe Term constructors & Patterns
|
||||
, annotate
|
||||
, annotatedVar
|
||||
, var
|
||||
, tm
|
||||
, tm'
|
||||
, abs
|
||||
, absChain
|
||||
, absChain'
|
||||
, abs'
|
||||
, absr
|
||||
, unabs
|
||||
, cycle
|
||||
, cycle'
|
||||
, cycler
|
||||
, pattern Abs'
|
||||
, pattern AbsN'
|
||||
, pattern Var'
|
||||
, pattern Cycle'
|
||||
, pattern CycleA'
|
||||
, pattern Tm'
|
||||
|
||||
-- * Algorithms
|
||||
, components
|
||||
, orderedComponents
|
||||
, hash
|
||||
, hashComponents
|
||||
) where
|
||||
|
||||
import Unison.Prelude
|
||||
|
||||
import Control.Lens (Lens', use, (.=))
|
||||
import Control.Monad.State (MonadState,evalState)
|
||||
import Control.Monad.State (MonadState)
|
||||
import Data.Functor.Identity (runIdentity)
|
||||
import Data.List hiding (cycle)
|
||||
import Control.Lens (Lens', use, (.=))
|
||||
import qualified Data.Foldable as Foldable
|
||||
import Data.List hiding (cycle, find)
|
||||
import Data.Vector ((!))
|
||||
import Prelude hiding (abs,cycle)
|
||||
import Prelude.Extras (Eq1(..), Show1(..), Ord1(..))
|
||||
import Unison.Hashable (Accumulate,Hashable1,hash1)
|
||||
import qualified Data.Foldable as Foldable
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Vector as Vector
|
||||
@ -29,7 +102,8 @@ data ABT f v r
|
||||
= Var v
|
||||
| Cycle r
|
||||
| Abs v r
|
||||
| Tm (f r) deriving (Functor, Foldable, Traversable)
|
||||
| Tm (f r)
|
||||
deriving (Functor, Foldable, Traversable)
|
||||
|
||||
-- | At each level in the tree, we store the set of free variables and
|
||||
-- a value of type `a`. Variables are of type `v`.
|
||||
@ -51,34 +125,6 @@ unvar (Bound v) = v
|
||||
instance Var v => Var (V v) where
|
||||
freshIn s v = freshIn (Set.map unvar s) <$> v
|
||||
|
||||
newtype Path s t a b m = Path { focus :: s -> Maybe (a, b -> Maybe t, m) }
|
||||
|
||||
here :: Monoid m => Path s t s t m
|
||||
here = Path $ \s -> Just (s, Just, mempty)
|
||||
|
||||
instance Semigroup (Path s t a b m) where
|
||||
(<>) = mappend
|
||||
|
||||
instance Monoid (Path s t a b m) where
|
||||
mempty = Path (const Nothing)
|
||||
mappend (Path p1) (Path p2) = Path p3 where
|
||||
p3 s = p1 s <|> p2 s
|
||||
|
||||
type Path' f g m = forall a v . Var v => Path (Term f v a) (Term f (V v) a) (Term g v a) (Term g (V v) a) m
|
||||
|
||||
compose :: Monoid m => Path s t a b m -> Path a b a' b' m -> Path s t a' b' m
|
||||
compose (Path p1) (Path p2) = Path p3 where
|
||||
p3 s = do
|
||||
(get1,set1,m1) <- p1 s
|
||||
(get2,set2,m2) <- p2 get1
|
||||
pure (get2, set2 >=> set1, m1 `mappend` m2)
|
||||
|
||||
at :: Path s t a b m -> s -> Maybe a
|
||||
at p s = (\(a,_,_) -> a) <$> focus p s
|
||||
|
||||
modify' :: Path s t a b m -> (m -> a -> b) -> s -> Maybe t
|
||||
modify' p f s = focus p s >>= \(get,set,m) -> set (f m get)
|
||||
|
||||
wrap :: (Functor f, Foldable f, Var v) => v -> Term f (V v) a -> (V v, Term f (V v) a)
|
||||
wrap v t =
|
||||
if Set.member (Free v) (freeVars t)
|
||||
@ -89,17 +135,6 @@ wrap' :: (Functor f, Foldable f, Var v)
|
||||
=> v -> Term f (V v) a -> (V v -> Term f (V v) a -> c) -> c
|
||||
wrap' v t f = uncurry f (wrap v t)
|
||||
|
||||
-- | Return the list of all variables bound by this ABT
|
||||
bound' :: Foldable f => Term f v a -> [v]
|
||||
bound' t = case out t of
|
||||
Abs v t -> v : bound' t
|
||||
Cycle t -> bound' t
|
||||
Tm f -> Foldable.toList f >>= bound'
|
||||
_ -> []
|
||||
|
||||
annotateBound' :: (Ord v, Functor f, Foldable f) => Term f v a0 -> Term f v [v]
|
||||
annotateBound' t = snd <$> annotateBound'' t
|
||||
|
||||
-- Annotate the tree with the set of bound variables at each node.
|
||||
annotateBound :: (Ord v, Foldable f, Functor f) => Term f v a -> Term f v (a, Set v)
|
||||
annotateBound = go Set.empty where
|
||||
@ -109,22 +144,6 @@ annotateBound = go Set.empty where
|
||||
Abs x body -> abs' a x (go (Set.insert x bound) body)
|
||||
Tm body -> tm' a (go bound <$> body)
|
||||
|
||||
annotateBound'' :: (Ord v, Functor f, Foldable f) => Term f v a -> Term f v (a, [v])
|
||||
annotateBound'' = go [] where
|
||||
go env t = let a = (annotation t, env) in case out t of
|
||||
Abs v body -> abs' a v (go (v : env) body)
|
||||
Cycle body -> cycle' a (go env body)
|
||||
Tm f -> tm' a (go env <$> f)
|
||||
Var v -> annotatedVar a v
|
||||
|
||||
-- | Return the set of all variables bound by this ABT
|
||||
bound :: (Ord v, Foldable f) => Term f v a -> Set v
|
||||
bound t = Set.fromList (bound' t)
|
||||
|
||||
-- | `True` if the term has no free variables, `False` otherwise
|
||||
isClosed :: Term f v a -> Bool
|
||||
isClosed t = Set.null (freeVars t)
|
||||
|
||||
-- | `True` if `v` is a member of the set of free variables of `t`
|
||||
isFreeIn :: Ord v => v -> Term f v a -> Bool
|
||||
isFreeIn v t = Set.member v (freeVars t)
|
||||
@ -179,18 +198,12 @@ pattern AbsN' vs body <- (unabs -> (vs, body))
|
||||
pattern Tm' f <- Term _ _ (Tm f)
|
||||
pattern CycleA' a avs t <- Term _ a (Cycle (AbsNA' avs t))
|
||||
pattern AbsNA' avs body <- (unabsA -> (avs, body))
|
||||
pattern Abs1NA' avs body <- (unabs1A -> Just (avs, body))
|
||||
|
||||
unabsA :: Term f v a -> ([(a,v)], Term f v a)
|
||||
unabsA (Term _ a (Abs hd body)) =
|
||||
let (tl, body') = unabsA body in ((a,hd) : tl, body')
|
||||
unabsA t = ([], t)
|
||||
|
||||
unabs1A :: Term f v a -> Maybe ([(a,v)], Term f v a)
|
||||
unabs1A t = case unabsA t of
|
||||
([], _) -> Nothing
|
||||
x -> Just x
|
||||
|
||||
var :: v -> Term f v ()
|
||||
var = annotatedVar ()
|
||||
|
||||
@ -238,16 +251,6 @@ cycler' a vs t = cycle' a $ foldr (absr' a) t vs
|
||||
cycler :: (Functor f, Foldable f, Var v) => [v] -> Term f (V v) () -> Term f (V v) ()
|
||||
cycler = cycler' ()
|
||||
|
||||
into :: (Foldable f, Ord v) => ABT f v (Term f v ()) -> Term f v ()
|
||||
into = into' ()
|
||||
|
||||
into' :: (Foldable f, Ord v) => a -> ABT f v (Term f v a) -> Term f v a
|
||||
into' a abt = case abt of
|
||||
Var x -> annotatedVar a x
|
||||
Cycle t -> cycle' a t
|
||||
Abs v r -> abs' a v r
|
||||
Tm t -> tm' a t
|
||||
|
||||
-- | renames `old` to `new` in the given term, ignoring subtrees that bind `old`
|
||||
rename :: (Foldable f, Functor f, Var v) => v -> v -> Term f v a -> Term f v a
|
||||
rename old new t0@(Term fvs ann t) =
|
||||
@ -317,9 +320,6 @@ freshInBoth t1 t2 = freshIn $ Set.union (freeVars t1) (freeVars t2)
|
||||
fresh :: Var v => Term f v a -> v -> v
|
||||
fresh t = freshIn (freeVars t)
|
||||
|
||||
freshEverywhere :: (Foldable f, Var v) => Term f v a -> v -> v
|
||||
freshEverywhere t = freshIn . Set.fromList $ allVars t
|
||||
|
||||
allVars :: Foldable f => Term f v a -> [v]
|
||||
allVars t = case out t of
|
||||
Var v -> [v]
|
||||
@ -327,12 +327,6 @@ allVars t = case out t of
|
||||
Abs v body -> v : allVars body
|
||||
Tm v -> Foldable.toList v >>= allVars
|
||||
|
||||
freshes :: Var v => Term f v a -> [v] -> [v]
|
||||
freshes = freshes' . freeVars
|
||||
|
||||
freshes' :: Var v => Set v -> [v] -> [v]
|
||||
freshes' used vs = evalState (traverse freshenS vs) used
|
||||
|
||||
-- | Freshens the given variable wrt. the set of used variables
|
||||
-- tracked by state. Adds the result to the set of used variables.
|
||||
freshenS :: (Var v, MonadState (Set v) m) => v -> m v
|
||||
@ -476,7 +470,7 @@ visit f t = flip fromMaybe (f t) $ case out t of
|
||||
Tm body -> tm' (annotation t) <$> traverse (visit f) body
|
||||
|
||||
-- | Apply an effectful function to an ABT tree top down, sequencing the results.
|
||||
visit' :: (Traversable f, Applicative g, Monad g, Ord v)
|
||||
visit' :: (Traversable f, Monad g, Ord v)
|
||||
=> (f (Term f v a) -> g (f (Term f v a)))
|
||||
-> Term f v a
|
||||
-> g (Term f v a)
|
||||
@ -519,9 +513,6 @@ unabs (Term _ _ (Abs hd body)) =
|
||||
let (tl, body') = unabs body in (hd : tl, body')
|
||||
unabs t = ([], t)
|
||||
|
||||
reabs :: Ord v => [v] -> Term f v () -> Term f v ()
|
||||
reabs vs t = foldr abs t vs
|
||||
|
||||
transform :: (Ord v, Foldable g, Functor f)
|
||||
=> (forall a. f a -> g a) -> Term f v a -> Term g v a
|
||||
transform f tm = case out tm of
|
||||
@ -735,22 +726,6 @@ hash = hash' [] where
|
||||
env -> (map (hash' env) ts', hash' env)
|
||||
hashCycle env ts = (map (hash' env) ts, hash' env)
|
||||
|
||||
-- | Use the `hash` function to efficiently remove duplicates from the list, preserving order.
|
||||
distinct :: forall f v h a proxy . (Functor f, Hashable1 f, Eq v, Show v, Ord h, Accumulate h)
|
||||
=> proxy h
|
||||
-> [Term f v a] -> [Term f v a]
|
||||
distinct _ ts = fst <$> sortOn snd m
|
||||
where m = Map.elems (Map.fromList (hashes `zip` (ts `zip` [0 :: Int .. 1])))
|
||||
hashes = map hash ts :: [h]
|
||||
|
||||
-- | Use the `hash` function to remove elements from `t1s` that exist in `t2s`, preserving order.
|
||||
subtract :: forall f v h a proxy . (Functor f, Hashable1 f, Eq v, Show v, Ord h, Accumulate h)
|
||||
=> proxy h
|
||||
-> [Term f v a] -> [Term f v a] -> [Term f v a]
|
||||
subtract _ t1s t2s =
|
||||
let skips = Set.fromList (map hash t2s :: [h])
|
||||
in filter (\t -> Set.notMember (hash t) skips) t1s
|
||||
|
||||
instance (Show1 f, Show v) => Show (Term f v a) where
|
||||
-- annotations not shown
|
||||
showsPrec p (Term _ _ out) = case out of
|
||||
|
@ -1,204 +0,0 @@
|
||||
{-# Language DeriveGeneric #-}
|
||||
|
||||
module Unison.Paths where
|
||||
|
||||
import Unison.Prelude
|
||||
|
||||
import Data.List
|
||||
import Unison.ABT (V)
|
||||
import Unison.Var (Var)
|
||||
import qualified Data.Sequence as Sequence
|
||||
import qualified Unison.ABT as ABT
|
||||
import qualified Unison.Term as E
|
||||
import qualified Unison.Type as T
|
||||
|
||||
type Type v = T.Type v ()
|
||||
type Term v = E.Term v ()
|
||||
|
||||
data Target v
|
||||
= Term (Term v)
|
||||
| Type (Type v)
|
||||
| Var v
|
||||
| Declaration v (Term v) deriving Generic
|
||||
-- Metadata
|
||||
|
||||
vmap :: Ord v2 => (v -> v2) -> Target v -> Target v2
|
||||
vmap f (Var v) = Var (f v)
|
||||
vmap f (Declaration v b) = Declaration (f v) (E.vmap f b)
|
||||
vmap f (Term t) = Term (E.vmap f t)
|
||||
vmap f (Type t) = Type (ABT.vmap f t)
|
||||
|
||||
data PathElement
|
||||
= Fn -- ^ Points at function in a function/type application
|
||||
| Arg -- ^ Points at the argument of a function/type application
|
||||
| Body -- ^ Points at the body of a lambda, let, binding, forall, or annotation
|
||||
| Bound -- ^ Points at the symbol bound by a `let`, `lambda` or `forall` binder
|
||||
| Binding !Int -- ^ Points at a particular binding in a let
|
||||
| Index !Int -- ^ Points at the index of a vector
|
||||
| Annotation -- ^ Points into the annotation
|
||||
| Input -- ^ Points at the left of an `Arrow`
|
||||
| Output -- ^ Points at the right of an `Arrow`
|
||||
deriving (Eq,Ord,Show,Generic)
|
||||
|
||||
focus1
|
||||
:: Var v
|
||||
=> PathElement
|
||||
-> ABT.Path (Target v) (Target (V v)) (Target v) (Target (V v)) [v]
|
||||
focus1 e = ABT.Path go'
|
||||
where
|
||||
go' t = go e t
|
||||
w = E.vmap ABT.Bound
|
||||
wt = ABT.vmap ABT.Bound
|
||||
go Fn (Term (E.App' fn arg)) = Just
|
||||
(Term fn, \fn -> Term <$> (E.app () <$> asTerm fn <*> pure (w arg)), [])
|
||||
go Fn (Type (T.App' fn arg)) =
|
||||
Just
|
||||
(Type fn, \fn -> Type <$> (T.app () <$> asType fn <*> pure (wt arg)), [])
|
||||
go Arg (Term (E.App' fn arg)) =
|
||||
Just (Term arg, \arg -> Term <$> (E.app () (w fn) <$> asTerm arg), [])
|
||||
go Arg (Type (T.App' fn arg)) =
|
||||
Just (Type arg, \arg -> Type <$> (T.app () (wt fn) <$> asType arg), [])
|
||||
go Body (Term (E.LamNamed' v body)) = Just
|
||||
(Term body, \t -> Term . set <$> asTerm t, [v])
|
||||
where set body = ABT.tm (E.Lam (ABT.absr v body))
|
||||
go Body (Term (E.Let1NamedTop' top v b body)) = Just
|
||||
(Term body, \t -> Term . set <$> asTerm t, [v])
|
||||
where set body = ABT.tm (E.Let top (w b) (ABT.absr v body))
|
||||
go p (Term (ABT.Cycle' vs (ABT.Tm' (E.LetRec top bs body)))) = case p of
|
||||
Body -> Just (Term body, \body -> Term . set <$> asTerm body, vs)
|
||||
where set body = ABT.cycler vs (ABT.tm (E.LetRec top (map w bs) body))
|
||||
Binding i | i >= 0 && i < length bs -> Just
|
||||
( Declaration (vs !! i) (bs !! i)
|
||||
, \b -> Term . set <$> asDeclaration b
|
||||
, vs
|
||||
)
|
||||
where
|
||||
replace f i a vs = map f (take i vs) ++ [a] ++ map f (drop (i + 1) vs)
|
||||
set (v, b) =
|
||||
let tm0 = ABT.tm (E.LetRec top (replace w i b bs) (w body))
|
||||
v0 = ABT.Bound (vs !! i)
|
||||
tm = if v /= v0 then ABT.rename v0 v tm0 else tm
|
||||
in ABT.cycler (replace id i (ABT.unvar v) vs) tm
|
||||
_ -> Nothing
|
||||
go Body (Type (T.ForallNamed' v body)) = Just
|
||||
(Type body, \t -> Type . set <$> asType t, [v])
|
||||
where set body = ABT.tm (T.Forall (ABT.absr v body))
|
||||
go Body (Declaration v body) =
|
||||
Just (Term body, \body -> Declaration (ABT.Bound v) <$> asTerm body, [])
|
||||
go Bound (Declaration v body) =
|
||||
Just (Var v, \v -> Declaration <$> asVar v <*> pure (w body), [])
|
||||
go Bound (Term (E.LamNamed' v body)) =
|
||||
Just (Var v, \v -> Term <$> (E.lam () <$> asVar v <*> pure (w body)), [])
|
||||
go Bound (Term (E.Let1NamedTop' top v b body)) = Just
|
||||
( Var v
|
||||
, \v -> (\v -> Term $ E.let1 top [(((), v), w b)] (w body)) <$> asVar v
|
||||
, []
|
||||
)
|
||||
go Bound (Type (T.ForallNamed' v body)) = Just
|
||||
(Var v, \v -> Type <$> (T.forall () <$> asVar v <*> pure (wt body)), [])
|
||||
go (Index i) (Term (E.List' vs)) | i < Sequence.length vs && i >= 0 = Just
|
||||
( Term (vs `Sequence.index` i)
|
||||
, \e -> (\e -> Term $ E.list' () $ Sequence.update i e (fmap w vs)) <$> asTerm e
|
||||
, []
|
||||
)
|
||||
go (Binding i) (Term (E.Let1NamedTop' top v b body)) | i <= 0 = Just
|
||||
(Declaration v b, set, [])
|
||||
where
|
||||
set (Declaration v b) = pure . Term $ E.let1 top [(((), v), b)] (w body)
|
||||
set _ = Nothing
|
||||
go Annotation (Term (E.Ann' e t)) =
|
||||
Just (Type t, \t -> Term . E.ann () (w e) <$> asType t, [])
|
||||
go Body (Term (E.Ann' body t)) = Just
|
||||
(Term body, \body -> Term . flip (E.ann ()) (wt t) <$> asTerm body, [])
|
||||
go Input (Type (T.Arrow' i o)) = Just
|
||||
(Type i, \i -> Type <$> (T.arrow () <$> asType i <*> pure (wt o)), [])
|
||||
go Output (Type (T.Arrow' i o)) =
|
||||
Just (Type o, \o -> Type . T.arrow () (wt i) <$> asType o, [])
|
||||
go _ _ = Nothing
|
||||
|
||||
type Path = [PathElement]
|
||||
|
||||
focus :: Var v => Path -> Target v -> Maybe (Target v, Target (V v) -> Maybe (Target v), [v])
|
||||
focus p t = tweak <$> ABT.focus (foldr ABT.compose ABT.here (map focus1 p)) t where
|
||||
tweak (get, set, vs) = (get, \t -> vmap ABT.unvar <$> set t, vs)
|
||||
|
||||
at :: Var v => Path -> Target v -> Maybe (Target v)
|
||||
at path t = (\(a,_,_) -> a) <$> focus path t
|
||||
|
||||
atTerm :: Var v => Path -> Term v -> Maybe (Term v)
|
||||
atTerm path t = asTerm =<< at path (Term t)
|
||||
|
||||
atType :: Var v => Path -> Type v -> Maybe (Type v)
|
||||
atType path t = asType =<< at path (Type t)
|
||||
|
||||
modify :: Var v => (Target v -> Target (V v)) -> Path -> Target v -> Maybe (Target v)
|
||||
modify f path t = focus path t >>= \(at,set,_) -> set (f at)
|
||||
|
||||
modifyTerm :: Var v => (Term v -> Term (V v)) -> Path -> Term v -> Maybe (Term v)
|
||||
modifyTerm f p t = do
|
||||
(at,set,_) <- focus p (Term t)
|
||||
t <- asTerm at
|
||||
asTerm =<< set (Term $ f t)
|
||||
|
||||
modifyTerm' :: Var v => (Term v -> Term (V v)) -> Path -> Term v -> Term v
|
||||
modifyTerm' f p t = fromMaybe t $ modifyTerm f p t
|
||||
|
||||
modifyType :: Var v => (Type v -> Type (V v)) -> Path -> Type v -> Maybe (Type v)
|
||||
modifyType f p t = do
|
||||
(at,set,_) <- focus p (Type t)
|
||||
t <- asType at
|
||||
asType =<< set (Type $ f t)
|
||||
|
||||
inScopeAt :: Var v => Path -> Target v -> [v]
|
||||
inScopeAt p t = maybe [] (\(_,_,vs) -> vs) (focus p t)
|
||||
|
||||
inScopeAtTerm :: Var v => Path -> Term v -> [v]
|
||||
inScopeAtTerm p t = inScopeAt p (Term t)
|
||||
|
||||
inScopeAtType :: Var v => Path -> Type v -> [v]
|
||||
inScopeAtType p t = inScopeAt p (Type t)
|
||||
|
||||
insertTerm :: Var v => Path -> Term v -> Maybe (Term v)
|
||||
insertTerm at _ | null at = Nothing
|
||||
insertTerm at ctx = do
|
||||
let at' = init at
|
||||
(parent,set,_) <- focus at' (Term ctx)
|
||||
case parent of
|
||||
Term (E.List' vs) -> do
|
||||
i <- listToMaybe [i | Index i <- toList (lastMay at)]
|
||||
let v2 = E.list'() ((E.vmap ABT.Bound <$> Sequence.take (i+1) vs) `mappend`
|
||||
pure (E.blank ()) `mappend`
|
||||
(E.vmap ABT.Bound <$> Sequence.drop (i+1) vs))
|
||||
asTerm =<< set (Term v2)
|
||||
_ -> Nothing -- todo - allow other types of insertions, like \x -> y to \x x2 -> y
|
||||
|
||||
-- | Return the list of all prefixes of the input path
|
||||
pathPrefixes :: Path -> [Path]
|
||||
pathPrefixes = inits
|
||||
|
||||
-- | Add an element onto the end of this 'Path'
|
||||
pathExtend :: PathElement -> Path -> Path
|
||||
pathExtend e p = p ++ [e]
|
||||
|
||||
parent :: Path -> Maybe Path
|
||||
parent [] = Nothing
|
||||
parent p = Just (init p)
|
||||
|
||||
parent' :: Path -> Path
|
||||
parent' = fromMaybe [] . parent
|
||||
|
||||
asTerm :: Target v -> Maybe (Term v)
|
||||
asTerm (Term t) = Just t
|
||||
asTerm _ = Nothing
|
||||
|
||||
asType :: Target v -> Maybe (Type v)
|
||||
asType (Type t) = Just t
|
||||
asType _ = Nothing
|
||||
|
||||
asVar :: Target v -> Maybe v
|
||||
asVar (Var v) = Just v
|
||||
asVar _ = Nothing
|
||||
|
||||
asDeclaration :: Target v -> Maybe (v, Term v)
|
||||
asDeclaration (Declaration v b) = Just (v,b)
|
||||
asDeclaration _ = Nothing
|
@ -42,7 +42,6 @@ library
|
||||
Unison.NameSegment
|
||||
Unison.NamesWithHistory
|
||||
Unison.OldName
|
||||
Unison.Paths
|
||||
Unison.Pattern
|
||||
Unison.Reference
|
||||
Unison.Reference.Util
|
||||
|
35
unison-src/transcripts-round-trip/docTest2.u
Normal file
35
unison-src/transcripts-round-trip/docTest2.u
Normal file
@ -0,0 +1,35 @@
|
||||
docTest2 : Doc2
|
||||
docTest2 =
|
||||
{{ # Full doc body indented
|
||||
|
||||
``` raw
|
||||
myVal1 = 42
|
||||
myVal2 = 43
|
||||
myVal4 = 44
|
||||
```
|
||||
|
||||
``` raw
|
||||
indented1= "hi"
|
||||
indented2="this is two indents"
|
||||
```
|
||||
|
||||
I am two spaces over }}
|
||||
|
||||
---- Anything below this line is ignored by Unison.
|
||||
|
||||
|
||||
docTest2 = {{
|
||||
# Full doc body indented
|
||||
|
||||
````raw
|
||||
myVal1 = 42
|
||||
myVal2 = 43
|
||||
myVal4 = 44
|
||||
````
|
||||
|
||||
````raw
|
||||
indented1= "hi"
|
||||
indented2="this is two indents"
|
||||
````
|
||||
I am two spaces over
|
||||
}}
|
@ -233,3 +233,25 @@ r = 'let
|
||||
.> load scratch.u
|
||||
```
|
||||
|
||||
## Raw codeblocks add indentation
|
||||
|
||||
Regression test for https://github.com/unisonweb/unison/issues/2271
|
||||
|
||||
```ucm
|
||||
.> load unison-src/transcripts-round-trip/docTest2.u
|
||||
.> add
|
||||
```
|
||||
|
||||
```unison:hide
|
||||
x = 2
|
||||
```
|
||||
|
||||
```ucm
|
||||
.> edit docTest2
|
||||
```
|
||||
|
||||
```ucm
|
||||
.> load scratch.u
|
||||
.> add
|
||||
```
|
||||
|
||||
|
@ -34,15 +34,15 @@ x = 1 + 1
|
||||
most recent, along with the command that got us there. Try:
|
||||
|
||||
`fork 2 .old`
|
||||
`fork #epnudil1fk .old` to make an old namespace
|
||||
`fork #umob2h2nfc .old` to make an old namespace
|
||||
accessible again,
|
||||
|
||||
`reset-root #epnudil1fk` to reset the root namespace and
|
||||
`reset-root #umob2h2nfc` to reset the root namespace and
|
||||
its history to that of the
|
||||
specified namespace.
|
||||
|
||||
1. #ugtr8mvop3 : add
|
||||
2. #epnudil1fk : builtins.mergeio
|
||||
1. #ec8bplo3a5 : add
|
||||
2. #umob2h2nfc : builtins.mergeio
|
||||
3. #sjg2v58vn2 : (initial reflogged namespace)
|
||||
|
||||
.> reset-root 2
|
||||
@ -116,17 +116,17 @@ Without the above stanza, the `edit` will send the definition to the most recent
|
||||
most recent, along with the command that got us there. Try:
|
||||
|
||||
`fork 2 .old`
|
||||
`fork #epnudil1fk .old` to make an old namespace
|
||||
`fork #umob2h2nfc .old` to make an old namespace
|
||||
accessible again,
|
||||
|
||||
`reset-root #epnudil1fk` to reset the root namespace and
|
||||
`reset-root #umob2h2nfc` to reset the root namespace and
|
||||
its history to that of the
|
||||
specified namespace.
|
||||
|
||||
1. #97dstg1ao2 : add
|
||||
2. #epnudil1fk : reset-root #epnudil1fk
|
||||
3. #ugtr8mvop3 : add
|
||||
4. #epnudil1fk : builtins.mergeio
|
||||
1. #nf6v4skcpk : add
|
||||
2. #umob2h2nfc : reset-root #umob2h2nfc
|
||||
3. #ec8bplo3a5 : add
|
||||
4. #umob2h2nfc : builtins.mergeio
|
||||
5. #sjg2v58vn2 : (initial reflogged namespace)
|
||||
|
||||
.> reset-root 2
|
||||
@ -191,19 +191,19 @@ f x = let
|
||||
most recent, along with the command that got us there. Try:
|
||||
|
||||
`fork 2 .old`
|
||||
`fork #epnudil1fk .old` to make an old namespace
|
||||
`fork #umob2h2nfc .old` to make an old namespace
|
||||
accessible again,
|
||||
|
||||
`reset-root #epnudil1fk` to reset the root namespace and
|
||||
`reset-root #umob2h2nfc` to reset the root namespace and
|
||||
its history to that of the
|
||||
specified namespace.
|
||||
|
||||
1. #hogb1vion0 : add
|
||||
2. #epnudil1fk : reset-root #epnudil1fk
|
||||
3. #97dstg1ao2 : add
|
||||
4. #epnudil1fk : reset-root #epnudil1fk
|
||||
5. #ugtr8mvop3 : add
|
||||
6. #epnudil1fk : builtins.mergeio
|
||||
1. #6u70tqt1nb : add
|
||||
2. #umob2h2nfc : reset-root #umob2h2nfc
|
||||
3. #nf6v4skcpk : add
|
||||
4. #umob2h2nfc : reset-root #umob2h2nfc
|
||||
5. #ec8bplo3a5 : add
|
||||
6. #umob2h2nfc : builtins.mergeio
|
||||
7. #sjg2v58vn2 : (initial reflogged namespace)
|
||||
|
||||
.> reset-root 2
|
||||
@ -273,21 +273,21 @@ h xs = match xs with
|
||||
most recent, along with the command that got us there. Try:
|
||||
|
||||
`fork 2 .old`
|
||||
`fork #epnudil1fk .old` to make an old namespace
|
||||
`fork #umob2h2nfc .old` to make an old namespace
|
||||
accessible again,
|
||||
|
||||
`reset-root #epnudil1fk` to reset the root namespace and
|
||||
`reset-root #umob2h2nfc` to reset the root namespace and
|
||||
its history to that of the
|
||||
specified namespace.
|
||||
|
||||
1. #7rhiegjl3c : add
|
||||
2. #epnudil1fk : reset-root #epnudil1fk
|
||||
3. #hogb1vion0 : add
|
||||
4. #epnudil1fk : reset-root #epnudil1fk
|
||||
5. #97dstg1ao2 : add
|
||||
6. #epnudil1fk : reset-root #epnudil1fk
|
||||
7. #ugtr8mvop3 : add
|
||||
8. #epnudil1fk : builtins.mergeio
|
||||
1. #8cfe45q2aq : add
|
||||
2. #umob2h2nfc : reset-root #umob2h2nfc
|
||||
3. #6u70tqt1nb : add
|
||||
4. #umob2h2nfc : reset-root #umob2h2nfc
|
||||
5. #nf6v4skcpk : add
|
||||
6. #umob2h2nfc : reset-root #umob2h2nfc
|
||||
7. #ec8bplo3a5 : add
|
||||
8. #umob2h2nfc : builtins.mergeio
|
||||
9. #sjg2v58vn2 : (initial reflogged namespace)
|
||||
|
||||
.> reset-root 2
|
||||
@ -353,23 +353,23 @@ foo n _ = n
|
||||
most recent, along with the command that got us there. Try:
|
||||
|
||||
`fork 2 .old`
|
||||
`fork #epnudil1fk .old` to make an old namespace
|
||||
`fork #umob2h2nfc .old` to make an old namespace
|
||||
accessible again,
|
||||
|
||||
`reset-root #epnudil1fk` to reset the root namespace and
|
||||
`reset-root #umob2h2nfc` to reset the root namespace and
|
||||
its history to that of the
|
||||
specified namespace.
|
||||
|
||||
1. #5bpdpn1048 : add
|
||||
2. #epnudil1fk : reset-root #epnudil1fk
|
||||
3. #7rhiegjl3c : add
|
||||
4. #epnudil1fk : reset-root #epnudil1fk
|
||||
5. #hogb1vion0 : add
|
||||
6. #epnudil1fk : reset-root #epnudil1fk
|
||||
7. #97dstg1ao2 : add
|
||||
8. #epnudil1fk : reset-root #epnudil1fk
|
||||
9. #ugtr8mvop3 : add
|
||||
10. #epnudil1fk : builtins.mergeio
|
||||
1. #lrkr6m9s84 : add
|
||||
2. #umob2h2nfc : reset-root #umob2h2nfc
|
||||
3. #8cfe45q2aq : add
|
||||
4. #umob2h2nfc : reset-root #umob2h2nfc
|
||||
5. #6u70tqt1nb : add
|
||||
6. #umob2h2nfc : reset-root #umob2h2nfc
|
||||
7. #nf6v4skcpk : add
|
||||
8. #umob2h2nfc : reset-root #umob2h2nfc
|
||||
9. #ec8bplo3a5 : add
|
||||
10. #umob2h2nfc : builtins.mergeio
|
||||
11. #sjg2v58vn2 : (initial reflogged namespace)
|
||||
|
||||
.> reset-root 2
|
||||
@ -432,25 +432,25 @@ foo =
|
||||
most recent, along with the command that got us there. Try:
|
||||
|
||||
`fork 2 .old`
|
||||
`fork #epnudil1fk .old` to make an old namespace
|
||||
`fork #umob2h2nfc .old` to make an old namespace
|
||||
accessible again,
|
||||
|
||||
`reset-root #epnudil1fk` to reset the root namespace and
|
||||
`reset-root #umob2h2nfc` to reset the root namespace and
|
||||
its history to that of the
|
||||
specified namespace.
|
||||
|
||||
1. #58g13u2vjv : add
|
||||
2. #epnudil1fk : reset-root #epnudil1fk
|
||||
3. #5bpdpn1048 : add
|
||||
4. #epnudil1fk : reset-root #epnudil1fk
|
||||
5. #7rhiegjl3c : add
|
||||
6. #epnudil1fk : reset-root #epnudil1fk
|
||||
7. #hogb1vion0 : add
|
||||
8. #epnudil1fk : reset-root #epnudil1fk
|
||||
9. #97dstg1ao2 : add
|
||||
10. #epnudil1fk : reset-root #epnudil1fk
|
||||
11. #ugtr8mvop3 : add
|
||||
12. #epnudil1fk : builtins.mergeio
|
||||
1. #4bomvvof2t : add
|
||||
2. #umob2h2nfc : reset-root #umob2h2nfc
|
||||
3. #lrkr6m9s84 : add
|
||||
4. #umob2h2nfc : reset-root #umob2h2nfc
|
||||
5. #8cfe45q2aq : add
|
||||
6. #umob2h2nfc : reset-root #umob2h2nfc
|
||||
7. #6u70tqt1nb : add
|
||||
8. #umob2h2nfc : reset-root #umob2h2nfc
|
||||
9. #nf6v4skcpk : add
|
||||
10. #umob2h2nfc : reset-root #umob2h2nfc
|
||||
11. #ec8bplo3a5 : add
|
||||
12. #umob2h2nfc : builtins.mergeio
|
||||
13. #sjg2v58vn2 : (initial reflogged namespace)
|
||||
|
||||
.> reset-root 2
|
||||
@ -693,3 +693,69 @@ r = 'let
|
||||
r : 'Nat
|
||||
|
||||
```
|
||||
## Raw codeblocks add indentation
|
||||
|
||||
Regression test for https://github.com/unisonweb/unison/issues/2271
|
||||
|
||||
```ucm
|
||||
.> load unison-src/transcripts-round-trip/docTest2.u
|
||||
|
||||
I found and typechecked these definitions in
|
||||
unison-src/transcripts-round-trip/docTest2.u. If you do an
|
||||
`add` or `update`, here's how your codebase would change:
|
||||
|
||||
⍟ These new definitions are ok to `add`:
|
||||
|
||||
docTest2 : Doc2
|
||||
|
||||
.> add
|
||||
|
||||
⍟ I've added these definitions:
|
||||
|
||||
docTest2 : Doc2
|
||||
|
||||
```
|
||||
```unison
|
||||
x = 2
|
||||
```
|
||||
|
||||
```ucm
|
||||
.> edit docTest2
|
||||
|
||||
☝️
|
||||
|
||||
I added these definitions to the top of
|
||||
/Users/runar/work/unison/scratch.u
|
||||
|
||||
docTest2 : Doc2
|
||||
docTest2 =
|
||||
{{ # Full doc body indented
|
||||
|
||||
``` raw
|
||||
myVal1 = 42
|
||||
myVal2 = 43
|
||||
myVal4 = 44
|
||||
```
|
||||
|
||||
``` raw
|
||||
indented1= "hi"
|
||||
indented2="this is two indents"
|
||||
```
|
||||
|
||||
I am two spaces over }}
|
||||
|
||||
You can edit them there, then do `update` to replace the
|
||||
definitions currently in this namespace.
|
||||
|
||||
```
|
||||
```ucm
|
||||
.> load scratch.u
|
||||
|
||||
I found and typechecked the definitions in scratch.u. This
|
||||
file has been previously added to the codebase.
|
||||
|
||||
.> add
|
||||
|
||||
⊡ Ignored previously added definitions: docTest2
|
||||
|
||||
```
|
||||
|
@ -13,7 +13,7 @@ The format is just a regular markdown file with some fenced code blocks that are
|
||||
$ ucm transcript hello.md
|
||||
```
|
||||
|
||||
This runs it on a freshly generated empty codebase. Alternately `ucm transcript.fork -codebase /path/to/code hello.md` runs the transcript on a freshly generated copy of the provided codebase. Do `ucm help` to learn more about usage.
|
||||
This runs it on a freshly generated empty codebase. Alternately `ucm transcript.fork --codebase /path/to/code hello.md` runs the transcript on a freshly generated copy of the provided codebase. Do `ucm help` to learn more about usage.
|
||||
|
||||
Fenced code blocks of type `unison` and `ucm` are treated specially:
|
||||
|
||||
|
@ -10,7 +10,7 @@ $ ucm transcript hello.md
|
||||
|
||||
```
|
||||
|
||||
This runs it on a freshly generated empty codebase. Alternately `ucm transcript.fork -codebase /path/to/code hello.md` runs the transcript on a freshly generated copy of the provided codebase. Do `ucm help` to learn more about usage.
|
||||
This runs it on a freshly generated empty codebase. Alternately `ucm transcript.fork --codebase /path/to/code hello.md` runs the transcript on a freshly generated copy of the provided codebase. Do `ucm help` to learn more about usage.
|
||||
|
||||
Fenced code blocks of type `unison` and `ucm` are treated specially:
|
||||
|
||||
|
@ -201,6 +201,40 @@ testSystemTime _ =
|
||||
.> io.test testSystemTime
|
||||
```
|
||||
|
||||
### Get temp directory
|
||||
|
||||
```unison:hide
|
||||
testGetTempDirectory : '{io2.IO} [Result]
|
||||
testGetTempDirectory _ =
|
||||
test = 'let
|
||||
tempDir = reraise !getTempDirectory.impl
|
||||
check "Temp directory is directory" (isDirectory tempDir)
|
||||
check "Temp directory should exist" (fileExists tempDir)
|
||||
runTest test
|
||||
```
|
||||
|
||||
```ucm
|
||||
.> add
|
||||
.> io.test testGetTempDirectory
|
||||
```
|
||||
|
||||
### Get current directory
|
||||
|
||||
```unison:hide
|
||||
testGetCurrentDirectory : '{io2.IO} [Result]
|
||||
testGetCurrentDirectory _ =
|
||||
test = 'let
|
||||
currentDir = reraise !getCurrentDirectory.impl
|
||||
check "Current directory is directory" (isDirectory currentDir)
|
||||
check "Current directory should exist" (fileExists currentDir)
|
||||
runTest test
|
||||
```
|
||||
|
||||
```ucm
|
||||
.> add
|
||||
.> io.test testGetCurrentDirectory
|
||||
```
|
||||
|
||||
### Get directory contents
|
||||
|
||||
```unison:hide
|
||||
|
@ -311,6 +311,70 @@ testSystemTime _ =
|
||||
|
||||
Tip: Use view testSystemTime to view the source of a test.
|
||||
|
||||
```
|
||||
### Get temp directory
|
||||
|
||||
```unison
|
||||
testGetTempDirectory : '{io2.IO} [Result]
|
||||
testGetTempDirectory _ =
|
||||
test = 'let
|
||||
tempDir = reraise !getTempDirectory.impl
|
||||
check "Temp directory is directory" (isDirectory tempDir)
|
||||
check "Temp directory should exist" (fileExists tempDir)
|
||||
runTest test
|
||||
```
|
||||
|
||||
```ucm
|
||||
.> add
|
||||
|
||||
⍟ I've added these definitions:
|
||||
|
||||
testGetTempDirectory : '{IO} [Result]
|
||||
|
||||
.> io.test testGetTempDirectory
|
||||
|
||||
New test results:
|
||||
|
||||
◉ testGetTempDirectory Temp directory is directory
|
||||
◉ testGetTempDirectory Temp directory should exist
|
||||
|
||||
✅ 2 test(s) passing
|
||||
|
||||
Tip: Use view testGetTempDirectory to view the source of a
|
||||
test.
|
||||
|
||||
```
|
||||
### Get current directory
|
||||
|
||||
```unison
|
||||
testGetCurrentDirectory : '{io2.IO} [Result]
|
||||
testGetCurrentDirectory _ =
|
||||
test = 'let
|
||||
currentDir = reraise !getCurrentDirectory.impl
|
||||
check "Current directory is directory" (isDirectory currentDir)
|
||||
check "Current directory should exist" (fileExists currentDir)
|
||||
runTest test
|
||||
```
|
||||
|
||||
```ucm
|
||||
.> add
|
||||
|
||||
⍟ I've added these definitions:
|
||||
|
||||
testGetCurrentDirectory : '{IO} [Result]
|
||||
|
||||
.> io.test testGetCurrentDirectory
|
||||
|
||||
New test results:
|
||||
|
||||
◉ testGetCurrentDirectory Current directory is directory
|
||||
◉ testGetCurrentDirectory Current directory should exist
|
||||
|
||||
✅ 2 test(s) passing
|
||||
|
||||
Tip: Use view testGetCurrentDirectory to view the source of a
|
||||
test.
|
||||
|
||||
```
|
||||
### Get directory contents
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user