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:
Mitchell Rosen
commit
fc7b6d9c22
@ -58,3 +58,4 @@ The format for this list: name, GitHub handle, and then optional blurb about wha
|
|||||||
* David Smith (@shmish111)
|
* David Smith (@shmish111)
|
||||||
* Chris Penner (@ChrisPenner)
|
* Chris Penner (@ChrisPenner)
|
||||||
* Rebecca Mark (@rlmark)
|
* Rebecca Mark (@rlmark)
|
||||||
|
* Evan Minsk (@iamevn)
|
||||||
|
|||||||
6
hie.yaml
6
hie.yaml
@ -45,11 +45,11 @@ cradle:
|
|||||||
- path: "parser-typechecker/tests"
|
- path: "parser-typechecker/tests"
|
||||||
component: "unison-parser-typechecker:exe:tests"
|
component: "unison-parser-typechecker:exe:tests"
|
||||||
|
|
||||||
- path: "cli/transcripts"
|
- path: "unison-cli/transcripts"
|
||||||
component: "unison-cli:exe:transcripts"
|
component: "unison-cli:exe:transcripts"
|
||||||
|
|
||||||
- path: "cli/unison"
|
- path: "unison-cli/unison"
|
||||||
component: "cli:exe:unison"
|
component: "unison-cli:exe:unison"
|
||||||
|
|
||||||
- path: "parser-typechecker/benchmarks/runtime"
|
- path: "parser-typechecker/benchmarks/runtime"
|
||||||
component: "unison-parser-typechecker:bench:runtime"
|
component: "unison-parser-typechecker:bench:runtime"
|
||||||
|
|||||||
@ -94,6 +94,7 @@ library:
|
|||||||
- safe-exceptions
|
- safe-exceptions
|
||||||
- mwc-random
|
- mwc-random
|
||||||
- NanoID
|
- NanoID
|
||||||
|
- lucid
|
||||||
- servant
|
- servant
|
||||||
- servant-docs
|
- servant-docs
|
||||||
- servant-openapi3
|
- servant-openapi3
|
||||||
|
|||||||
@ -138,7 +138,7 @@ openNewUcmCodebaseOrExit cbInit debugName path = do
|
|||||||
Codebase.installUcmDependencies codebase
|
Codebase.installUcmDependencies codebase
|
||||||
pure x
|
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 :: MonadIO m => Init m Symbol Ann -> DebugName -> Maybe CodebasePath -> m ()
|
||||||
initCodebaseAndExit i debugName mdir =
|
initCodebaseAndExit i debugName mdir =
|
||||||
void $ openNewUcmCodebaseOrExit i debugName =<< Codebase.getCodebaseDir mdir
|
void $ openNewUcmCodebaseOrExit i debugName =<< Codebase.getCodebaseDir mdir
|
||||||
|
|||||||
@ -289,7 +289,7 @@ run dir configFile stanzas codebase = do
|
|||||||
"\128721", "",
|
"\128721", "",
|
||||||
"The transcript failed due to an error in the stanza above. The error is:", "",
|
"The transcript failed due to an error in the stanza above. The error is:", "",
|
||||||
Text.pack msg, "",
|
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 :: IO ()
|
||||||
dieUnexpectedSuccess = do
|
dieUnexpectedSuccess = do
|
||||||
@ -302,7 +302,7 @@ run dir configFile stanzas codebase = do
|
|||||||
transcriptFailure out $ Text.unlines [
|
transcriptFailure out $ Text.unlines [
|
||||||
"\128721", "",
|
"\128721", "",
|
||||||
"The transcript was expecting an error in the stanza above, but did not encounter one.", "",
|
"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
|
loop state = do
|
||||||
writeIORef pathRef (view HandleInput.currentPath state)
|
writeIORef pathRef (view HandleInput.currentPath state)
|
||||||
|
|||||||
@ -5,7 +5,6 @@ module Unison.Hashing.V2.Convert
|
|||||||
hashDecls,
|
hashDecls,
|
||||||
hashClosedTerm,
|
hashClosedTerm,
|
||||||
hashTermComponents,
|
hashTermComponents,
|
||||||
hashTypeComponents,
|
|
||||||
typeToReference,
|
typeToReference,
|
||||||
typeToReferenceMentions,
|
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 :: Var v => Memory.Type.Type v a -> Set Memory.Reference.Reference
|
||||||
typeToReferenceMentions = Set.map h2mReference . Hashing.Type.toReferenceMentions . m2hType . Memory.Type.removeAllEffectVars
|
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 :: 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
|
hashTermComponents = fmap h2mTermResult . Hashing.Term.hashComponents . fmap m2hTerm
|
||||||
where
|
where
|
||||||
|
|||||||
@ -25,7 +25,6 @@ import Control.Lens (over, _3)
|
|||||||
import Data.Bifunctor (first, second)
|
import Data.Bifunctor (first, second)
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
import Prelude.Extras (Show1)
|
|
||||||
import Unison.Var (Var)
|
import Unison.Var (Var)
|
||||||
import qualified Unison.ABT as ABT
|
import qualified Unison.ABT as ABT
|
||||||
import qualified Unison.ConstructorType as CT
|
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.Name as Name
|
||||||
import qualified Unison.Names.ResolutionResult as Names
|
import qualified Unison.Names.ResolutionResult as Names
|
||||||
import Unison.Prelude
|
import Unison.Prelude
|
||||||
-- import qualified Unison.Referent as Referent
|
|
||||||
-- import qualified Unison.Referent' as Referent'
|
|
||||||
import Prelude hiding (cycle)
|
import Prelude hiding (cycle)
|
||||||
|
|
||||||
type Decl v a = Either (EffectDeclaration v a) (DataDeclaration v a)
|
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 :: Decl v a -> DataDeclaration v a
|
||||||
asDataDecl = either toDataDecl id
|
asDataDecl = either toDataDecl id
|
||||||
|
|
||||||
@ -71,12 +63,12 @@ data DataDeclaration v a = DataDeclaration
|
|||||||
bound :: [v],
|
bound :: [v],
|
||||||
constructors' :: [(a, v, Type v a)]
|
constructors' :: [(a, v, Type v a)]
|
||||||
}
|
}
|
||||||
deriving (Eq, Show, Functor)
|
deriving (Functor)
|
||||||
|
|
||||||
newtype EffectDeclaration v a = EffectDeclaration
|
newtype EffectDeclaration v a = EffectDeclaration
|
||||||
{ toDataDecl :: DataDeclaration v a
|
{ toDataDecl :: DataDeclaration v a
|
||||||
}
|
}
|
||||||
deriving (Eq, Show, Functor)
|
deriving (Functor)
|
||||||
|
|
||||||
constructorTypes :: DataDeclaration v a -> [Type v a]
|
constructorTypes :: DataDeclaration v a -> [Type v a]
|
||||||
constructorTypes = (snd <$>) . constructors
|
constructorTypes = (snd <$>) . constructors
|
||||||
@ -148,7 +140,7 @@ data F a
|
|||||||
| LetRec [a] a
|
| LetRec [a] a
|
||||||
| Constructors [a]
|
| Constructors [a]
|
||||||
| Modified Modifier a
|
| Modified Modifier a
|
||||||
deriving (Functor, Foldable, Show, Show1)
|
deriving (Functor, Foldable)
|
||||||
|
|
||||||
instance Hashable1 F where
|
instance Hashable1 F where
|
||||||
hash1 hashCycle hash e =
|
hash1 hashCycle hash e =
|
||||||
|
|||||||
File diff suppressed because it is too large
Load Diff
@ -5,27 +5,40 @@
|
|||||||
{-# LANGUAGE Rank2Types #-}
|
{-# LANGUAGE Rank2Types #-}
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# 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 Unison.Prelude
|
||||||
|
|
||||||
import qualified Control.Monad.Writer.Strict as Writer
|
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.Map as Map
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
import Prelude.Extras (Eq1(..),Show1(..),Ord1(..))
|
|
||||||
import qualified Unison.ABT as ABT
|
import qualified Unison.ABT as ABT
|
||||||
import Unison.Hashable (Hashable1)
|
import Unison.Hashable (Hashable1)
|
||||||
import qualified Unison.Hashable as Hashable
|
import qualified Unison.Hashable as Hashable
|
||||||
import qualified Unison.Kind as K
|
import qualified Unison.Kind as K
|
||||||
import Unison.Hashing.V2.Reference (Reference)
|
import Unison.Hashing.V2.Reference (Reference)
|
||||||
import qualified Unison.Hashing.V2.Reference as Reference
|
import qualified Unison.Hashing.V2.Reference as Reference
|
||||||
import qualified Unison.Hashing.V2.Reference.Util as ReferenceUtil
|
|
||||||
import Unison.Var (Var)
|
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.Names.ResolutionResult as Names
|
||||||
import qualified Unison.Name as Name
|
import qualified Unison.Name as Name
|
||||||
import qualified Unison.Util.List as List
|
import qualified Unison.Util.List as List
|
||||||
@ -42,18 +55,11 @@ data F a
|
|||||||
| IntroOuter a -- binder like ∀, used to introduce variables that are
|
| IntroOuter a -- binder like ∀, used to introduce variables that are
|
||||||
-- bound by outer type signatures, to support scoped type
|
-- bound by outer type signatures, to support scoped type
|
||||||
-- variables
|
-- variables
|
||||||
deriving (Foldable,Functor,Generic,Generic1,Eq,Ord,Traversable)
|
deriving (Foldable,Functor,Traversable)
|
||||||
|
|
||||||
instance Eq1 F where (==#) = (==)
|
|
||||||
instance Ord1 F where compare1 = compare
|
|
||||||
instance Show1 F where showsPrec1 = showsPrec
|
|
||||||
|
|
||||||
-- | Types are represented as ABTs over the base functor F, with variables in `v`
|
-- | Types are represented as ABTs over the base functor F, with variables in `v`
|
||||||
type Type v a = ABT.Term F v a
|
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 :: Type v a -> Set v
|
||||||
freeVars = ABT.freeVars
|
freeVars = ABT.freeVars
|
||||||
|
|
||||||
@ -74,107 +80,10 @@ bindReferences keepFree ns t = let
|
|||||||
ok (v, a, Nothing) = Left (pure (Names.TypeResolutionFailure v a Names.NotFound))
|
ok (v, a, Nothing) = Left (pure (Names.TypeResolutionFailure v a Names.NotFound))
|
||||||
in List.validate ok rs <&> \es -> bindExternal es t
|
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
|
-- some smart patterns
|
||||||
pattern Ref' r <- ABT.Tm' (Ref r)
|
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 ForallsNamed' vs body <- (unForalls -> Just (vs, body))
|
||||||
pattern ForallNamed' v body <- ABT.Tm' (Forall (ABT.out -> ABT.Abs v 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 :: Type v a -> Maybe ([v], Type v a)
|
||||||
unForalls t = go t []
|
unForalls t = go t []
|
||||||
@ -182,38 +91,11 @@ unForalls t = go t []
|
|||||||
go _body [] = Nothing
|
go _body [] = Nothing
|
||||||
go body vs = Just(reverse vs, body)
|
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
|
-- some smart constructors
|
||||||
|
|
||||||
ref :: Ord v => a -> Reference -> Type v a
|
ref :: Ord v => a -> Reference -> Type v a
|
||||||
ref a = ABT.tm' a . Ref
|
ref a = ABT.tm' a . Ref
|
||||||
|
|
||||||
refId :: Ord v => a -> Reference.Id -> Type v a
|
intRef, natRef, floatRef, booleanRef, textRef, charRef, listRef, effectRef :: Reference
|
||||||
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 = Reference.Builtin "Int"
|
intRef = Reference.Builtin "Int"
|
||||||
natRef = Reference.Builtin "Nat"
|
natRef = Reference.Builtin "Nat"
|
||||||
floatRef = Reference.Builtin "Float"
|
floatRef = Reference.Builtin "Float"
|
||||||
@ -221,223 +103,11 @@ booleanRef = Reference.Builtin "Boolean"
|
|||||||
textRef = Reference.Builtin "Text"
|
textRef = Reference.Builtin "Text"
|
||||||
charRef = Reference.Builtin "Char"
|
charRef = Reference.Builtin "Char"
|
||||||
listRef = Reference.Builtin "Sequence"
|
listRef = Reference.Builtin "Sequence"
|
||||||
bytesRef = Reference.Builtin "Bytes"
|
|
||||||
effectRef = Reference.Builtin "Effect"
|
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 :: Ord v => a -> v -> Type v a -> Type v a
|
||||||
forall a v body = ABT.tm' a (Forall (ABT.abs' a v body))
|
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`.
|
-- | 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 :: Ord v => [v] -> Type v a -> Type v a
|
||||||
generalize vs t = foldr f t vs
|
generalize vs t = foldr f t vs
|
||||||
@ -445,10 +115,6 @@ generalize vs t = foldr f t vs
|
|||||||
f v t =
|
f v t =
|
||||||
if Set.member v (ABT.freeVars t) then forall (ABT.annotation t) v t else 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' :: Type v a -> ([v], Type v a)
|
||||||
unforall' (ForallsNamed' vs t) = (vs, t)
|
unforall' (ForallsNamed' vs t) = (vs, t)
|
||||||
unforall' t = ([], 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
|
where f t@(Ref r) = Writer.tell [r] $> t
|
||||||
f t = pure 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 :: (ABT.Var v, Show v) => Type v a -> Reference
|
||||||
toReference (Ref' r) = r
|
toReference (Ref' r) = r
|
||||||
-- a bit of normalization - any unused type parameters aren't part of the hash
|
-- 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
|
gen ty = generalize (Set.toList (freeVars ty)) $ generalize vs ty
|
||||||
in Set.fromList $ toReference . gen <$> ABT.subterms 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
|
instance Hashable1 F where
|
||||||
hash1 hashCycle hash e =
|
hash1 hashCycle hash e =
|
||||||
let
|
let
|
||||||
@ -697,25 +157,3 @@ instance Hashable1 F where
|
|||||||
Effect e t -> [tag 5, hashed (hash e), hashed (hash t)]
|
Effect e t -> [tag 5, hashed (hash e), hashed (hash t)]
|
||||||
Forall a -> [tag 6, hashed (hash a)]
|
Forall a -> [tag 6, hashed (hash a)]
|
||||||
IntroOuter a -> [tag 7, 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" })
|
local (\env -> env { inLayout = True, opening = Just "docExampleBlock" })
|
||||||
(restoreStack "docExampleBlock" $ lexemes' ([] <$ lit fence))
|
(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
|
other = wrap "syntax.docCodeBlock" $ do
|
||||||
fence <- lit "```" <+> P.many (CP.satisfy (== '`'))
|
column <- (\x -> x - 1) . toInteger . P.unPos <$> LP.indentLevel
|
||||||
name <- P.many (CP.satisfy nonNewlineSpace)
|
tabWidth <- toInteger . P.unPos <$> P.getTabWidth
|
||||||
*> tok (Textual <$> P.takeWhile1P Nothing (not . isSpace))
|
fence <- lit "```" <+> P.many (CP.satisfy (== '`'))
|
||||||
_ <- CP.space
|
name <-
|
||||||
verbatim <- tok $ Textual . trim <$> P.someTill CP.anyChar ([] <$ lit fence)
|
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)
|
pure (name <> verbatim)
|
||||||
|
|
||||||
boldOrItalicOrStrikethrough closing = do
|
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 (Parsing e) = prettyParseError s e
|
||||||
printNoteWithSource env s (TypeError e) = prettyTypecheckError e env s
|
printNoteWithSource env s (TypeError e) = prettyTypecheckError e env s
|
||||||
printNoteWithSource _env _s (NameResolutionFailures _es) = undefined
|
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) =
|
printNoteWithSource _env s (UnknownSymbol v a) =
|
||||||
fromString ("Unknown symbol `" ++ Text.unpack (Var.name v) ++ "`\n\n")
|
fromString ("Unknown symbol `" ++ Text.unpack (Var.name v) ++ "`\n\n")
|
||||||
<> annotatedAsErrorSite s a
|
<> annotatedAsErrorSite s a
|
||||||
|
|||||||
@ -15,7 +15,6 @@ import Control.Monad.Writer ( WriterT(..)
|
|||||||
)
|
)
|
||||||
import Unison.Name ( Name )
|
import Unison.Name ( Name )
|
||||||
import qualified Unison.Parser as Parser
|
import qualified Unison.Parser as Parser
|
||||||
import Unison.Paths ( Path )
|
|
||||||
import Unison.Term ( Term )
|
import Unison.Term ( Term )
|
||||||
import qualified Unison.Typechecker.Context as Context
|
import qualified Unison.Typechecker.Context as Context
|
||||||
import Control.Error.Util ( note)
|
import Control.Error.Util ( note)
|
||||||
@ -28,7 +27,6 @@ type ResultT notes f = MaybeT (WriterT notes f)
|
|||||||
data Note v loc
|
data Note v loc
|
||||||
= Parsing (Parser.Err v)
|
= Parsing (Parser.Err v)
|
||||||
| NameResolutionFailures [Names.ResolutionFailure v loc]
|
| NameResolutionFailures [Names.ResolutionFailure v loc]
|
||||||
| InvalidPath Path (Term v loc) -- todo: move me!
|
|
||||||
| UnknownSymbol v loc
|
| UnknownSymbol v loc
|
||||||
| TypeError (Context.ErrorNote v loc)
|
| TypeError (Context.ErrorNote v loc)
|
||||||
| TypeInfo (Context.InfoNote v loc)
|
| TypeInfo (Context.InfoNote v loc)
|
||||||
|
|||||||
@ -1596,7 +1596,7 @@ declareForeigns = do
|
|||||||
temp <- getTemporaryDirectory
|
temp <- getTemporaryDirectory
|
||||||
createTempDirectory temp prefix
|
createTempDirectory temp prefix
|
||||||
|
|
||||||
declareForeign "IO.getCurrentDirectory.impl.v3" direct
|
declareForeign "IO.getCurrentDirectory.impl.v3" unitToEFBox
|
||||||
. mkForeignIOF $ \() -> getCurrentDirectory
|
. mkForeignIOF $ \() -> getCurrentDirectory
|
||||||
|
|
||||||
declareForeign "IO.setCurrentDirectory.impl.v3" boxToEF0
|
declareForeign "IO.setCurrentDirectory.impl.v3" boxToEF0
|
||||||
|
|||||||
@ -84,7 +84,7 @@ data Doc
|
|||||||
|
|
||||||
type UnisonHash = Text
|
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
|
data SpecialForm
|
||||||
= Source [Ref (UnisonHash, DisplayObject SyntaxText Src)]
|
= Source [Ref (UnisonHash, DisplayObject SyntaxText Src)]
|
||||||
@ -259,7 +259,7 @@ renderDoc pped terms typeOf eval types tm = eval tm >>= \case
|
|||||||
acc' = case tm of
|
acc' = case tm of
|
||||||
Term.Ref' r | Set.notMember r seen -> (:acc) . Term . (Reference.toText r,) <$> case r of
|
Term.Ref' r | Set.notMember r seen -> (:acc) . Term . (Reference.toText r,) <$> case r of
|
||||||
Reference.Builtin _ -> typeOf (Referent.Ref r) <&> \case
|
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)
|
Just ty -> DO.BuiltinObject (formatPrettyType ppe ty)
|
||||||
ref -> terms ref >>= \case
|
ref -> terms ref >>= \case
|
||||||
Nothing -> pure $ DO.MissingObject (SH.unsafeFromText $ Reference.toText ref)
|
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
|
-> (Set.insert ref seen,) . (:acc) <$> goType ref
|
||||||
_ -> pure s1
|
_ -> pure s1
|
||||||
reverse . snd <$> foldM go mempty es
|
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 DeriveAnyClass #-}
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE DerivingVia #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE StandaloneDeriving #-}
|
{-# LANGUAGE StandaloneDeriving #-}
|
||||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
{-# 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
|
-- evolve separately. This is the version which is outward facing
|
||||||
-- to the server frontend.
|
-- to the server frontend.
|
||||||
module Unison.Server.Syntax where
|
module Unison.Server.Syntax where
|
||||||
|
|
||||||
import Data.Aeson ( ToJSON )
|
import Data.Aeson (ToJSON)
|
||||||
import Data.OpenApi ( ToSchema(..) )
|
import qualified Data.List as List
|
||||||
import Unison.Prelude
|
import qualified Data.List.NonEmpty as List.NonEmpty
|
||||||
import qualified Unison.HashQualified as HashQualified
|
import Data.OpenApi (ToSchema (..))
|
||||||
import Unison.Pattern ( SeqOp(..) )
|
import Data.Proxy (Proxy (..))
|
||||||
|
import qualified Data.Text as Text
|
||||||
import Unison.Util.AnnotatedText ( AnnotatedText(..)
|
import Lucid
|
||||||
, Segment(..)
|
import qualified Lucid as L
|
||||||
, annotate
|
import qualified Unison.HashQualified as HashQualified
|
||||||
, segment
|
import Unison.Name (Name)
|
||||||
)
|
import qualified Unison.Name as Name
|
||||||
import qualified Unison.Util.SyntaxText as SyntaxText
|
import qualified Unison.NameSegment as NameSegment
|
||||||
import Unison.Reference ( Reference )
|
import Unison.Pattern (SeqOp (..))
|
||||||
import qualified Unison.Reference as Reference
|
import Unison.Prelude
|
||||||
import qualified Unison.Referent as Referent
|
import Unison.Reference (Reference)
|
||||||
import Data.Proxy ( Proxy(..) )
|
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 SyntaxText = AnnotatedText Element
|
||||||
|
|
||||||
|
type SyntaxSegment = Segment Element
|
||||||
|
|
||||||
instance ToJSON Element
|
instance ToJSON Element
|
||||||
|
|
||||||
deriving instance ToSchema Element
|
deriving instance ToSchema Element
|
||||||
@ -49,88 +61,248 @@ instance ToSchema r => ToSchema (Seq r) where
|
|||||||
|
|
||||||
convertElement :: SyntaxText.Element Reference -> Element
|
convertElement :: SyntaxText.Element Reference -> Element
|
||||||
convertElement = \case
|
convertElement = \case
|
||||||
SyntaxText.NumericLiteral -> NumericLiteral
|
SyntaxText.NumericLiteral -> NumericLiteral
|
||||||
SyntaxText.TextLiteral -> TextLiteral
|
SyntaxText.TextLiteral -> TextLiteral
|
||||||
SyntaxText.BytesLiteral -> BytesLiteral
|
SyntaxText.BytesLiteral -> BytesLiteral
|
||||||
SyntaxText.CharLiteral -> CharLiteral
|
SyntaxText.CharLiteral -> CharLiteral
|
||||||
SyntaxText.BooleanLiteral -> BooleanLiteral
|
SyntaxText.BooleanLiteral -> BooleanLiteral
|
||||||
SyntaxText.Blank -> Blank
|
SyntaxText.Blank -> Blank
|
||||||
SyntaxText.Var -> Var
|
SyntaxText.Var -> Var
|
||||||
SyntaxText.Referent r -> TermReference $ Referent.toText r
|
SyntaxText.Referent r -> TermReference $ Referent.toText r
|
||||||
SyntaxText.Reference r -> TypeReference $ Reference.toText r
|
SyntaxText.Reference r -> TypeReference $ Reference.toText r
|
||||||
SyntaxText.Op s -> Op s
|
SyntaxText.Op s -> Op s
|
||||||
SyntaxText.AbilityBraces -> AbilityBraces
|
SyntaxText.AbilityBraces -> AbilityBraces
|
||||||
SyntaxText.ControlKeyword -> ControlKeyword
|
SyntaxText.ControlKeyword -> ControlKeyword
|
||||||
SyntaxText.TypeOperator -> TypeOperator
|
SyntaxText.TypeOperator -> TypeOperator
|
||||||
SyntaxText.BindingEquals -> BindingEquals
|
SyntaxText.BindingEquals -> BindingEquals
|
||||||
SyntaxText.TypeAscriptionColon -> TypeAscriptionColon
|
SyntaxText.TypeAscriptionColon -> TypeAscriptionColon
|
||||||
SyntaxText.DataTypeKeyword -> DataTypeKeyword
|
SyntaxText.DataTypeKeyword -> DataTypeKeyword
|
||||||
SyntaxText.DataTypeParams -> DataTypeParams
|
SyntaxText.DataTypeParams -> DataTypeParams
|
||||||
SyntaxText.Unit -> Unit
|
SyntaxText.Unit -> Unit
|
||||||
SyntaxText.DataTypeModifier -> DataTypeModifier
|
SyntaxText.DataTypeModifier -> DataTypeModifier
|
||||||
SyntaxText.UseKeyword -> UseKeyword
|
SyntaxText.UseKeyword -> UseKeyword
|
||||||
SyntaxText.UsePrefix -> UsePrefix
|
SyntaxText.UsePrefix -> UsePrefix
|
||||||
SyntaxText.UseSuffix -> UseSuffix
|
SyntaxText.UseSuffix -> UseSuffix
|
||||||
SyntaxText.HashQualifier n -> HashQualifier (HashQualified.toText n)
|
SyntaxText.HashQualifier n -> HashQualifier (HashQualified.toText n)
|
||||||
SyntaxText.DelayForceChar -> DelayForceChar
|
SyntaxText.DelayForceChar -> DelayForceChar
|
||||||
SyntaxText.DelimiterChar -> DelimiterChar
|
SyntaxText.DelimiterChar -> DelimiterChar
|
||||||
SyntaxText.Parenthesis -> Parenthesis
|
SyntaxText.Parenthesis -> Parenthesis
|
||||||
SyntaxText.LinkKeyword -> LinkKeyword
|
SyntaxText.LinkKeyword -> LinkKeyword
|
||||||
SyntaxText.DocDelimiter -> DocDelimiter
|
SyntaxText.DocDelimiter -> DocDelimiter
|
||||||
SyntaxText.DocKeyword -> DocKeyword
|
SyntaxText.DocKeyword -> DocKeyword
|
||||||
|
|
||||||
type UnisonHash = Text
|
type UnisonHash = Text
|
||||||
|
|
||||||
type HashQualifiedName = Text
|
type HashQualifiedName = Text
|
||||||
|
|
||||||
-- The elements of the Unison grammar, for syntax highlighting purposes
|
-- | The elements of the Unison grammar, for syntax highlighting purposes
|
||||||
data Element = NumericLiteral
|
data Element
|
||||||
| TextLiteral
|
= NumericLiteral
|
||||||
| BytesLiteral
|
| TextLiteral
|
||||||
| CharLiteral
|
| BytesLiteral
|
||||||
| BooleanLiteral
|
| CharLiteral
|
||||||
| Blank
|
| BooleanLiteral
|
||||||
| Var
|
| Blank
|
||||||
| TypeReference UnisonHash
|
| Var
|
||||||
| TermReference UnisonHash
|
| TypeReference UnisonHash
|
||||||
| Op SeqOp
|
| DataConstructorReference UnisonHash
|
||||||
| Constructor
|
| AbilityConstructorReference UnisonHash
|
||||||
| Request
|
| TermReference UnisonHash
|
||||||
| AbilityBraces
|
| Op SeqOp
|
||||||
-- let|handle|in|where|match|with|cases|->|if|then|else|and|or
|
| -- | Constructor Are these even used?
|
||||||
| ControlKeyword
|
-- | Request
|
||||||
-- forall|->
|
AbilityBraces
|
||||||
| TypeOperator
|
| -- let|handle|in|where|match|with|cases|->|if|then|else|and|or
|
||||||
| BindingEquals
|
ControlKeyword
|
||||||
| TypeAscriptionColon
|
| -- forall|->
|
||||||
-- type|ability
|
TypeOperator
|
||||||
| DataTypeKeyword
|
| BindingEquals
|
||||||
| DataTypeParams
|
| TypeAscriptionColon
|
||||||
| Unit
|
| -- type|ability
|
||||||
-- unique
|
DataTypeKeyword
|
||||||
| DataTypeModifier
|
| DataTypeParams
|
||||||
-- `use Foo bar` is keyword, prefix, suffix
|
| Unit
|
||||||
| UseKeyword
|
| -- unique
|
||||||
| UsePrefix
|
DataTypeModifier
|
||||||
| UseSuffix
|
| -- `use Foo bar` is keyword, prefix, suffix
|
||||||
| HashQualifier HashQualifiedName
|
UseKeyword
|
||||||
| DelayForceChar
|
| UsePrefix
|
||||||
-- ? , ` [ ] @ |
|
| UseSuffix
|
||||||
-- Currently not all commas in the pretty-print output are marked up as DelimiterChar - we miss
|
| HashQualifier HashQualifiedName
|
||||||
-- out characters emitted by Pretty.hs helpers like Pretty.commas.
|
| DelayForceChar
|
||||||
| DelimiterChar
|
| -- ? , ` [ ] @ |
|
||||||
-- ! '
|
-- Currently not all commas in the pretty-print output are marked up as DelimiterChar - we miss
|
||||||
| Parenthesis
|
-- out characters emitted by Pretty.hs helpers like Pretty.commas.
|
||||||
| LinkKeyword -- `typeLink` and `termLink`
|
DelimiterChar
|
||||||
-- [: :] @[]
|
| -- ! '
|
||||||
| DocDelimiter
|
Parenthesis
|
||||||
-- the 'include' in @[include], etc
|
| LinkKeyword -- `typeLink` and `termLink`
|
||||||
| DocKeyword
|
-- [: :] @[]
|
||||||
deriving (Eq, Ord, Show, Generic)
|
| DocDelimiter
|
||||||
|
| -- the 'include' in @[include], etc
|
||||||
|
DocKeyword
|
||||||
|
deriving (Eq, Ord, Show, Generic)
|
||||||
|
|
||||||
syntax :: Element -> SyntaxText -> SyntaxText
|
syntax :: Element -> SyntaxText -> SyntaxText
|
||||||
syntax = annotate
|
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 :: SyntaxText -> String
|
||||||
toPlain (AnnotatedText at) = join (toList $ segment <$> at)
|
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
|
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
|
-- | Infer the type of a 'Unison.Term', using
|
||||||
-- a function to resolve the type of @Ref@ constructors
|
-- a function to resolve the type of @Ref@ constructors
|
||||||
-- contained in that term.
|
-- contained in that term.
|
||||||
|
|||||||
@ -139,6 +139,7 @@ library
|
|||||||
Unison.Server.Backend
|
Unison.Server.Backend
|
||||||
Unison.Server.CodebaseServer
|
Unison.Server.CodebaseServer
|
||||||
Unison.Server.Doc
|
Unison.Server.Doc
|
||||||
|
Unison.Server.Doc.AsHtml
|
||||||
Unison.Server.Endpoints.FuzzyFind
|
Unison.Server.Endpoints.FuzzyFind
|
||||||
Unison.Server.Endpoints.GetDefinitions
|
Unison.Server.Endpoints.GetDefinitions
|
||||||
Unison.Server.Endpoints.NamespaceDetails
|
Unison.Server.Endpoints.NamespaceDetails
|
||||||
@ -246,6 +247,7 @@ library
|
|||||||
, http-media
|
, http-media
|
||||||
, http-types
|
, http-types
|
||||||
, lens
|
, lens
|
||||||
|
, lucid
|
||||||
, megaparsec >=5.0.0 && <7.0.0
|
, megaparsec >=5.0.0 && <7.0.0
|
||||||
, memory
|
, memory
|
||||||
, mmorph
|
, mmorph
|
||||||
|
|||||||
@ -13,7 +13,7 @@ packages:
|
|||||||
- yaks/easytest
|
- yaks/easytest
|
||||||
- parser-typechecker
|
- parser-typechecker
|
||||||
- unison-core
|
- unison-core
|
||||||
- cli
|
- unison-cli
|
||||||
- codebase2/codebase
|
- codebase2/codebase
|
||||||
- codebase2/codebase-sqlite
|
- codebase2/codebase-sqlite
|
||||||
- codebase2/codebase-sync
|
- codebase2/codebase-sync
|
||||||
|
|||||||
@ -5,20 +5,93 @@
|
|||||||
{-# LANGUAGE PatternSynonyms #-}
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
{-# LANGUAGE Rank2Types #-}
|
{-# LANGUAGE Rank2Types #-}
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# 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 Unison.Prelude
|
||||||
|
import Control.Monad.State (MonadState)
|
||||||
import Control.Lens (Lens', use, (.=))
|
|
||||||
import Control.Monad.State (MonadState,evalState)
|
|
||||||
import Data.Functor.Identity (runIdentity)
|
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 Data.Vector ((!))
|
||||||
import Prelude hiding (abs,cycle)
|
import Prelude hiding (abs,cycle)
|
||||||
import Prelude.Extras (Eq1(..), Show1(..), Ord1(..))
|
import Prelude.Extras (Eq1(..), Show1(..), Ord1(..))
|
||||||
import Unison.Hashable (Accumulate,Hashable1,hash1)
|
import Unison.Hashable (Accumulate,Hashable1,hash1)
|
||||||
import qualified Data.Foldable as Foldable
|
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
import qualified Data.Vector as Vector
|
import qualified Data.Vector as Vector
|
||||||
@ -29,7 +102,8 @@ data ABT f v r
|
|||||||
= Var v
|
= Var v
|
||||||
| Cycle r
|
| Cycle r
|
||||||
| Abs v 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
|
-- | At each level in the tree, we store the set of free variables and
|
||||||
-- a value of type `a`. Variables are of type `v`.
|
-- 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
|
instance Var v => Var (V v) where
|
||||||
freshIn s v = freshIn (Set.map unvar s) <$> v
|
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 :: (Functor f, Foldable f, Var v) => v -> Term f (V v) a -> (V v, Term f (V v) a)
|
||||||
wrap v t =
|
wrap v t =
|
||||||
if Set.member (Free v) (freeVars 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
|
=> v -> Term f (V v) a -> (V v -> Term f (V v) a -> c) -> c
|
||||||
wrap' v t f = uncurry f (wrap v t)
|
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.
|
-- 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 :: (Ord v, Foldable f, Functor f) => Term f v a -> Term f v (a, Set v)
|
||||||
annotateBound = go Set.empty where
|
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)
|
Abs x body -> abs' a x (go (Set.insert x bound) body)
|
||||||
Tm body -> tm' a (go 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`
|
-- | `True` if `v` is a member of the set of free variables of `t`
|
||||||
isFreeIn :: Ord v => v -> Term f v a -> Bool
|
isFreeIn :: Ord v => v -> Term f v a -> Bool
|
||||||
isFreeIn v t = Set.member v (freeVars t)
|
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 Tm' f <- Term _ _ (Tm f)
|
||||||
pattern CycleA' a avs t <- Term _ a (Cycle (AbsNA' avs t))
|
pattern CycleA' a avs t <- Term _ a (Cycle (AbsNA' avs t))
|
||||||
pattern AbsNA' avs body <- (unabsA -> (avs, body))
|
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 f v a -> ([(a,v)], Term f v a)
|
||||||
unabsA (Term _ a (Abs hd body)) =
|
unabsA (Term _ a (Abs hd body)) =
|
||||||
let (tl, body') = unabsA body in ((a,hd) : tl, body')
|
let (tl, body') = unabsA body in ((a,hd) : tl, body')
|
||||||
unabsA t = ([], t)
|
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 :: v -> Term f v ()
|
||||||
var = annotatedVar ()
|
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 :: (Functor f, Foldable f, Var v) => [v] -> Term f (V v) () -> Term f (V v) ()
|
||||||
cycler = cycler' ()
|
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`
|
-- | 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 :: (Foldable f, Functor f, Var v) => v -> v -> Term f v a -> Term f v a
|
||||||
rename old new t0@(Term fvs ann t) =
|
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 :: Var v => Term f v a -> v -> v
|
||||||
fresh t = freshIn (freeVars t)
|
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 :: Foldable f => Term f v a -> [v]
|
||||||
allVars t = case out t of
|
allVars t = case out t of
|
||||||
Var v -> [v]
|
Var v -> [v]
|
||||||
@ -327,12 +327,6 @@ allVars t = case out t of
|
|||||||
Abs v body -> v : allVars body
|
Abs v body -> v : allVars body
|
||||||
Tm v -> Foldable.toList v >>= allVars
|
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
|
-- | Freshens the given variable wrt. the set of used variables
|
||||||
-- tracked by state. Adds the result to 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
|
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
|
Tm body -> tm' (annotation t) <$> traverse (visit f) body
|
||||||
|
|
||||||
-- | Apply an effectful function to an ABT tree top down, sequencing the results.
|
-- | 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)))
|
=> (f (Term f v a) -> g (f (Term f v a)))
|
||||||
-> Term f v a
|
-> Term f v a
|
||||||
-> g (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')
|
let (tl, body') = unabs body in (hd : tl, body')
|
||||||
unabs t = ([], t)
|
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)
|
transform :: (Ord v, Foldable g, Functor f)
|
||||||
=> (forall a. f a -> g a) -> Term f v a -> Term g v a
|
=> (forall a. f a -> g a) -> Term f v a -> Term g v a
|
||||||
transform f tm = case out tm of
|
transform f tm = case out tm of
|
||||||
@ -735,22 +726,6 @@ hash = hash' [] where
|
|||||||
env -> (map (hash' env) ts', hash' env)
|
env -> (map (hash' env) ts', hash' env)
|
||||||
hashCycle env ts = (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
|
instance (Show1 f, Show v) => Show (Term f v a) where
|
||||||
-- annotations not shown
|
-- annotations not shown
|
||||||
showsPrec p (Term _ _ out) = case out of
|
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.NameSegment
|
||||||
Unison.NamesWithHistory
|
Unison.NamesWithHistory
|
||||||
Unison.OldName
|
Unison.OldName
|
||||||
Unison.Paths
|
|
||||||
Unison.Pattern
|
Unison.Pattern
|
||||||
Unison.Reference
|
Unison.Reference
|
||||||
Unison.Reference.Util
|
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
|
.> 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:
|
most recent, along with the command that got us there. Try:
|
||||||
|
|
||||||
`fork 2 .old`
|
`fork 2 .old`
|
||||||
`fork #epnudil1fk .old` to make an old namespace
|
`fork #umob2h2nfc .old` to make an old namespace
|
||||||
accessible again,
|
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
|
its history to that of the
|
||||||
specified namespace.
|
specified namespace.
|
||||||
|
|
||||||
1. #ugtr8mvop3 : add
|
1. #ec8bplo3a5 : add
|
||||||
2. #epnudil1fk : builtins.mergeio
|
2. #umob2h2nfc : builtins.mergeio
|
||||||
3. #sjg2v58vn2 : (initial reflogged namespace)
|
3. #sjg2v58vn2 : (initial reflogged namespace)
|
||||||
|
|
||||||
.> reset-root 2
|
.> 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:
|
most recent, along with the command that got us there. Try:
|
||||||
|
|
||||||
`fork 2 .old`
|
`fork 2 .old`
|
||||||
`fork #epnudil1fk .old` to make an old namespace
|
`fork #umob2h2nfc .old` to make an old namespace
|
||||||
accessible again,
|
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
|
its history to that of the
|
||||||
specified namespace.
|
specified namespace.
|
||||||
|
|
||||||
1. #97dstg1ao2 : add
|
1. #nf6v4skcpk : add
|
||||||
2. #epnudil1fk : reset-root #epnudil1fk
|
2. #umob2h2nfc : reset-root #umob2h2nfc
|
||||||
3. #ugtr8mvop3 : add
|
3. #ec8bplo3a5 : add
|
||||||
4. #epnudil1fk : builtins.mergeio
|
4. #umob2h2nfc : builtins.mergeio
|
||||||
5. #sjg2v58vn2 : (initial reflogged namespace)
|
5. #sjg2v58vn2 : (initial reflogged namespace)
|
||||||
|
|
||||||
.> reset-root 2
|
.> reset-root 2
|
||||||
@ -191,19 +191,19 @@ f x = let
|
|||||||
most recent, along with the command that got us there. Try:
|
most recent, along with the command that got us there. Try:
|
||||||
|
|
||||||
`fork 2 .old`
|
`fork 2 .old`
|
||||||
`fork #epnudil1fk .old` to make an old namespace
|
`fork #umob2h2nfc .old` to make an old namespace
|
||||||
accessible again,
|
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
|
its history to that of the
|
||||||
specified namespace.
|
specified namespace.
|
||||||
|
|
||||||
1. #hogb1vion0 : add
|
1. #6u70tqt1nb : add
|
||||||
2. #epnudil1fk : reset-root #epnudil1fk
|
2. #umob2h2nfc : reset-root #umob2h2nfc
|
||||||
3. #97dstg1ao2 : add
|
3. #nf6v4skcpk : add
|
||||||
4. #epnudil1fk : reset-root #epnudil1fk
|
4. #umob2h2nfc : reset-root #umob2h2nfc
|
||||||
5. #ugtr8mvop3 : add
|
5. #ec8bplo3a5 : add
|
||||||
6. #epnudil1fk : builtins.mergeio
|
6. #umob2h2nfc : builtins.mergeio
|
||||||
7. #sjg2v58vn2 : (initial reflogged namespace)
|
7. #sjg2v58vn2 : (initial reflogged namespace)
|
||||||
|
|
||||||
.> reset-root 2
|
.> reset-root 2
|
||||||
@ -273,21 +273,21 @@ h xs = match xs with
|
|||||||
most recent, along with the command that got us there. Try:
|
most recent, along with the command that got us there. Try:
|
||||||
|
|
||||||
`fork 2 .old`
|
`fork 2 .old`
|
||||||
`fork #epnudil1fk .old` to make an old namespace
|
`fork #umob2h2nfc .old` to make an old namespace
|
||||||
accessible again,
|
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
|
its history to that of the
|
||||||
specified namespace.
|
specified namespace.
|
||||||
|
|
||||||
1. #7rhiegjl3c : add
|
1. #8cfe45q2aq : add
|
||||||
2. #epnudil1fk : reset-root #epnudil1fk
|
2. #umob2h2nfc : reset-root #umob2h2nfc
|
||||||
3. #hogb1vion0 : add
|
3. #6u70tqt1nb : add
|
||||||
4. #epnudil1fk : reset-root #epnudil1fk
|
4. #umob2h2nfc : reset-root #umob2h2nfc
|
||||||
5. #97dstg1ao2 : add
|
5. #nf6v4skcpk : add
|
||||||
6. #epnudil1fk : reset-root #epnudil1fk
|
6. #umob2h2nfc : reset-root #umob2h2nfc
|
||||||
7. #ugtr8mvop3 : add
|
7. #ec8bplo3a5 : add
|
||||||
8. #epnudil1fk : builtins.mergeio
|
8. #umob2h2nfc : builtins.mergeio
|
||||||
9. #sjg2v58vn2 : (initial reflogged namespace)
|
9. #sjg2v58vn2 : (initial reflogged namespace)
|
||||||
|
|
||||||
.> reset-root 2
|
.> reset-root 2
|
||||||
@ -353,23 +353,23 @@ foo n _ = n
|
|||||||
most recent, along with the command that got us there. Try:
|
most recent, along with the command that got us there. Try:
|
||||||
|
|
||||||
`fork 2 .old`
|
`fork 2 .old`
|
||||||
`fork #epnudil1fk .old` to make an old namespace
|
`fork #umob2h2nfc .old` to make an old namespace
|
||||||
accessible again,
|
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
|
its history to that of the
|
||||||
specified namespace.
|
specified namespace.
|
||||||
|
|
||||||
1. #5bpdpn1048 : add
|
1. #lrkr6m9s84 : add
|
||||||
2. #epnudil1fk : reset-root #epnudil1fk
|
2. #umob2h2nfc : reset-root #umob2h2nfc
|
||||||
3. #7rhiegjl3c : add
|
3. #8cfe45q2aq : add
|
||||||
4. #epnudil1fk : reset-root #epnudil1fk
|
4. #umob2h2nfc : reset-root #umob2h2nfc
|
||||||
5. #hogb1vion0 : add
|
5. #6u70tqt1nb : add
|
||||||
6. #epnudil1fk : reset-root #epnudil1fk
|
6. #umob2h2nfc : reset-root #umob2h2nfc
|
||||||
7. #97dstg1ao2 : add
|
7. #nf6v4skcpk : add
|
||||||
8. #epnudil1fk : reset-root #epnudil1fk
|
8. #umob2h2nfc : reset-root #umob2h2nfc
|
||||||
9. #ugtr8mvop3 : add
|
9. #ec8bplo3a5 : add
|
||||||
10. #epnudil1fk : builtins.mergeio
|
10. #umob2h2nfc : builtins.mergeio
|
||||||
11. #sjg2v58vn2 : (initial reflogged namespace)
|
11. #sjg2v58vn2 : (initial reflogged namespace)
|
||||||
|
|
||||||
.> reset-root 2
|
.> reset-root 2
|
||||||
@ -432,25 +432,25 @@ foo =
|
|||||||
most recent, along with the command that got us there. Try:
|
most recent, along with the command that got us there. Try:
|
||||||
|
|
||||||
`fork 2 .old`
|
`fork 2 .old`
|
||||||
`fork #epnudil1fk .old` to make an old namespace
|
`fork #umob2h2nfc .old` to make an old namespace
|
||||||
accessible again,
|
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
|
its history to that of the
|
||||||
specified namespace.
|
specified namespace.
|
||||||
|
|
||||||
1. #58g13u2vjv : add
|
1. #4bomvvof2t : add
|
||||||
2. #epnudil1fk : reset-root #epnudil1fk
|
2. #umob2h2nfc : reset-root #umob2h2nfc
|
||||||
3. #5bpdpn1048 : add
|
3. #lrkr6m9s84 : add
|
||||||
4. #epnudil1fk : reset-root #epnudil1fk
|
4. #umob2h2nfc : reset-root #umob2h2nfc
|
||||||
5. #7rhiegjl3c : add
|
5. #8cfe45q2aq : add
|
||||||
6. #epnudil1fk : reset-root #epnudil1fk
|
6. #umob2h2nfc : reset-root #umob2h2nfc
|
||||||
7. #hogb1vion0 : add
|
7. #6u70tqt1nb : add
|
||||||
8. #epnudil1fk : reset-root #epnudil1fk
|
8. #umob2h2nfc : reset-root #umob2h2nfc
|
||||||
9. #97dstg1ao2 : add
|
9. #nf6v4skcpk : add
|
||||||
10. #epnudil1fk : reset-root #epnudil1fk
|
10. #umob2h2nfc : reset-root #umob2h2nfc
|
||||||
11. #ugtr8mvop3 : add
|
11. #ec8bplo3a5 : add
|
||||||
12. #epnudil1fk : builtins.mergeio
|
12. #umob2h2nfc : builtins.mergeio
|
||||||
13. #sjg2v58vn2 : (initial reflogged namespace)
|
13. #sjg2v58vn2 : (initial reflogged namespace)
|
||||||
|
|
||||||
.> reset-root 2
|
.> reset-root 2
|
||||||
@ -693,3 +693,69 @@ r = 'let
|
|||||||
r : 'Nat
|
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
|
$ 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:
|
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:
|
Fenced code blocks of type `unison` and `ucm` are treated specially:
|
||||||
|
|
||||||
|
|||||||
@ -201,6 +201,40 @@ testSystemTime _ =
|
|||||||
.> io.test 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
|
### Get directory contents
|
||||||
|
|
||||||
```unison:hide
|
```unison:hide
|
||||||
|
|||||||
@ -311,6 +311,70 @@ testSystemTime _ =
|
|||||||
|
|
||||||
Tip: Use view testSystemTime to view the source of a test.
|
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
|
### Get directory contents
|
||||||
|
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user