mirror of
https://github.com/unisonweb/unison.git
synced 2024-11-15 04:11:34 +03:00
more builtins, WIP on view cycling
This commit is contained in:
Paul Chiusano
parent
6fc6fb2d24
commit
600e84a372
@ -246,7 +246,7 @@ click : Sink Field.Content -> (Int,Int) -> (Int,Int) -> Action
|
||||
click searchbox origin (x,y) model = case model.explorer of
|
||||
Nothing -> case Layout.leafAtPoint model.layouts.panel (Pt x y) of
|
||||
Nothing -> norequest model -- noop, user didn't click on anything!
|
||||
Just node -> openExplorer searchbox model
|
||||
Just node -> openExplorer searchbox origin model
|
||||
Just _ -> case Layout.leafAtPoint model.layouts.explorer (Pt x y) of
|
||||
Nothing -> norequest (closeExplorer model) -- treat this as a close event
|
||||
Just (Result.Ok i) -> norequest (close origin { model | explorerSelection <- i }) -- close w/ selection
|
||||
@ -327,18 +327,20 @@ accept model = Maybe.withDefault model <|
|
||||
\scope -> Term.set scope.focus model.term term `Maybe.andThen`
|
||||
\t2 -> Just <| clearScopeHistory { model | term <- t2 }
|
||||
|
||||
openExplorer : Sink Field.Content -> Action
|
||||
openExplorer : Sink Field.Content -> (Int,Int) -> Action
|
||||
openExplorer = openExplorerWith Field.noContent
|
||||
|
||||
openExplorerWith : Field.Content -> Sink Field.Content -> Action
|
||||
openExplorerWith content searchbox model =
|
||||
openExplorerWith : Field.Content -> Sink Field.Content -> (Int,Int) -> Action
|
||||
openExplorerWith content searchbox origin model =
|
||||
let zero = Maybe.map (\z -> { z | input <- content }) Explorer.zero
|
||||
(req, m2) = openRequest { model | explorer <- zero
|
||||
, localInfo <- Nothing
|
||||
, searchResults <- Nothing
|
||||
, explorerSelection <- 0
|
||||
, literal <- Nothing }
|
||||
in (req, refreshExplorer searchbox m2)
|
||||
m2 = refreshPanel Nothing origin
|
||||
{ model | explorer <- zero
|
||||
, localInfo <- Nothing
|
||||
, searchResults <- Nothing
|
||||
, explorerSelection <- 0
|
||||
, literal <- Nothing }
|
||||
(req, m2') = openRequest m2
|
||||
in (req, refreshExplorer searchbox m2')
|
||||
|
||||
-- todo: invalidate dependents and overrides if under the edit path
|
||||
|
||||
@ -388,13 +390,12 @@ setSearchbox sink origin modifier content model =
|
||||
|> clearScopeHistory
|
||||
|> scopeMovement (Movement.D2 Movement.Zero Movement.Negative)
|
||||
|> refreshPanel Nothing origin
|
||||
|> openExplorerWith (leftover (String.fromChar op)) sink
|
||||
|> openExplorerWith (leftover (String.fromChar op)) sink origin
|
||||
| op == ' ' ->
|
||||
snd (action model)
|
||||
|> accept
|
||||
|> scopeMovement (Movement.D2 Movement.Positive Movement.Zero)
|
||||
|> refreshPanel Nothing origin
|
||||
|> openExplorer sink
|
||||
|> openExplorer sink origin
|
||||
| allowApplication model ->
|
||||
snd (action model)
|
||||
|> accept
|
||||
@ -405,8 +406,7 @@ setSearchbox sink origin modifier content model =
|
||||
|> clearScopeHistory
|
||||
|> scopeMovement (Movement.D2 Movement.Zero Movement.Negative)
|
||||
|> scopeMovement (Movement.D2 Movement.Positive Movement.Zero)
|
||||
|> refreshPanel Nothing origin
|
||||
|> openExplorerWith (leftover (String.fromChar op)) sink
|
||||
|> openExplorerWith (leftover (String.fromChar op)) sink origin
|
||||
| otherwise -> let ex = Explorer.setInput content model.explorer
|
||||
in action { model | explorer <- ex }
|
||||
literal e model =
|
||||
@ -457,15 +457,13 @@ refreshPanel searchbox origin model =
|
||||
{ rootMetadata = model.rootMetadata
|
||||
, availableWidth = availableWidth - fst origin
|
||||
, metadata = metadata model
|
||||
, overrides p =
|
||||
let u = Debug.log "overrides p" p
|
||||
in Trie.lookup p model.overrides
|
||||
, overrides p = Trie.lookup p model.overrides
|
||||
, raw = Trie.empty }
|
||||
overrideFocus env availableWidth = Maybe.withDefault (env availableWidth) <|
|
||||
model.scope `Maybe.andThen`
|
||||
\scope -> model.explorer `Maybe.andThen`
|
||||
\_ -> let env0 = env availableWidth
|
||||
in Just { env0 | raw <- Trie.insert scope.focus () env0.raw }
|
||||
in Just { env0 | raw <- Debug.log "raw" (Trie.insert scope.focus () env0.raw )}
|
||||
layout = pin origin <| case model.availableWidth of
|
||||
Nothing -> layout0
|
||||
Just availableWidth -> View.layout model.term (overrideFocus env availableWidth)
|
||||
@ -727,8 +725,8 @@ main =
|
||||
ms = models inputs
|
||||
(search2 (Signal.send inputs.searchbox) origin)
|
||||
{ model0 | term <- expr }
|
||||
debug model =
|
||||
model |> Debug.watchSummary "explorer" .explorer
|
||||
|> Debug.watchSummary "status" .status
|
||||
debug model = case model.scope of
|
||||
Nothing -> model
|
||||
Just scope -> let u = Debug.log "focus" scope.focus in model
|
||||
ms' = Signal.map debug ms
|
||||
in Signal.map view ms'
|
||||
|
||||
@ -79,7 +79,7 @@ betaReduce : Term -> Term
|
||||
betaReduce e =
|
||||
let go depth arg body = case body of
|
||||
App f x -> App (go depth arg f) (go depth arg x)
|
||||
Vector vs -> Vector (Array.map (go depth arg) vs)
|
||||
Vector vs -> Vector (Array.fromList (List.map (go depth arg) (Array.toList vs)))
|
||||
Ann body t -> Ann (go depth arg body) t
|
||||
Lam body -> Lam (go (V.succ depth) arg body)
|
||||
Var v -> if v == depth then arg else Var v
|
||||
|
||||
@ -312,7 +312,7 @@ palette : View Color
|
||||
rgb : Int -> Int -> Int -> Color
|
||||
source : View a
|
||||
text : Style -> View String
|
||||
textboxt : Alignment -> Distance -> Style -> View String
|
||||
textbox : Alignment -> Distance -> Style -> View String
|
||||
reactive : View a -> View a
|
||||
fn : (Panel -> Panel) -> View (a -> b)
|
||||
cell (fn f)
|
||||
@ -329,9 +329,9 @@ panel : View a -> a -> Panel
|
||||
cell : View a -> a -> a
|
||||
Text.{left, right, center, justify} : Alignment
|
||||
|
||||
panel vertical [
|
||||
panel source "hello",
|
||||
panel source (1 + 23)
|
||||
cell vertical [
|
||||
cell source "hello",
|
||||
cell source (1 + 23)
|
||||
]
|
||||
panel view (panel blah x)
|
||||
-}
|
||||
@ -393,14 +393,14 @@ builtins env allowBreak availableWidth ambientPrec cur =
|
||||
let f i e = impl env allowBreak ambientPrec availableWidth
|
||||
{ cur | path <- cur.path `append` [Arg, Path.Index i], term <- e }
|
||||
in Just (L.vertical (tag (cur.path `snoc` Arg)) (List.indexedMap f (Array.toList es)))
|
||||
Ref (R.Builtin "View.id") -> builtins env allowBreak availableWidth ambientPrec
|
||||
Ref (R.Builtin "View.embed") -> builtins env allowBreak availableWidth ambientPrec
|
||||
{ cur | path <- cur.path `snoc` Arg, term <- e }
|
||||
Ref (R.Builtin "View.wrap") -> case e of
|
||||
Vector es -> Nothing -- todo more complicated, as we need to do sequencing
|
||||
_ -> Nothing
|
||||
_ -> Nothing
|
||||
in case cur.term of
|
||||
App (App (App (Ref (R.Builtin "View.cell")) (App (Ref (R.Builtin "View.function1")) (Lam body))) f) e ->
|
||||
App (App (App (Ref (R.Builtin "View.view")) (App (Ref (R.Builtin "View.function1")) (Lam body))) f) e ->
|
||||
-- all paths will point to `f` aside from `e`
|
||||
let eview = impl env allowBreak 0 availableWidth
|
||||
{ cur | path <- cur.path `snoc` Arg, term <- e }
|
||||
@ -411,7 +411,7 @@ builtins env allowBreak availableWidth ambientPrec cur =
|
||||
{ cur | path <- fpath, term <- betaReduce (App (Lam body) (unclose view)) }
|
||||
|> L.map trim
|
||||
in Maybe.map g eview
|
||||
App (App (Ref (R.Builtin "View.panel")) v) e -> go v e
|
||||
App (App (Ref (R.Builtin "View.cell")) v) e -> go v e
|
||||
App (App (Ref (R.Builtin "View.view")) v) e -> go v e
|
||||
_ -> Nothing
|
||||
|
||||
|
||||
@ -49,37 +49,93 @@ string2 sym f = I.Primop 2 $ \xs -> case xs of
|
||||
(x,y) -> sym `Term.App` x `Term.App` y
|
||||
_ -> error "unpossible"
|
||||
|
||||
builtins :: [(R.Reference, I.Primop (N.Noted IO), Type, Metadata R.Reference)]
|
||||
builtins :: [(R.Reference, Maybe (I.Primop (N.Noted IO)), Type, Metadata R.Reference)]
|
||||
builtins =
|
||||
[ let r = R.Builtin "Number.plus"
|
||||
in (r, numeric2 (Term.Ref r) (+), numOpTyp, opl 4 "+")
|
||||
[ let r = R.Builtin "()"
|
||||
in (r, Nothing, unitT, prefix "()")
|
||||
|
||||
, let r = R.Builtin "Color.rgba"
|
||||
in (r, Nothing, num `arr` (num `arr` (num `arr` (num `arr` colorT))), prefix "rgba")
|
||||
|
||||
, let r = R.Builtin "Number.plus"
|
||||
in (r, Just (numeric2 (Term.Ref r) (+)), numOpTyp, opl 4 "+")
|
||||
, let r = R.Builtin "Number.minus"
|
||||
in (r, numeric2 (Term.Ref r) (-), numOpTyp, opl 4 "-")
|
||||
in (r, Just (numeric2 (Term.Ref r) (-)), numOpTyp, opl 4 "-")
|
||||
, let r = R.Builtin "Number.times"
|
||||
in (r, numeric2 (Term.Ref r) (*), numOpTyp, opl 5 "*")
|
||||
in (r, Just (numeric2 (Term.Ref r) (*)), numOpTyp, opl 5 "*")
|
||||
, let r = R.Builtin "Number.divide"
|
||||
in (r, numeric2 (Term.Ref r) (/), numOpTyp, opl 5 "/")
|
||||
in (r, Just (numeric2 (Term.Ref r) (/)), numOpTyp, opl 5 "/")
|
||||
|
||||
, let r = R.Builtin "Text.append"
|
||||
in (r, string2 (Term.Ref r) mappend, strOpTyp, prefix "append")
|
||||
-- , let r = R.Builtin "View.cell"
|
||||
-- t = error "todo.view.cell"
|
||||
-- in (r, nf r 2, T.forall1 $ \a -> )
|
||||
in (r, Just (string2 (Term.Ref r) mappend), strOpTyp, prefixes ["append", "Text"])
|
||||
, let r = R.Builtin "Text.left"
|
||||
in (r, Nothing, alignmentT, prefixes ["left", "Text"])
|
||||
, let r = R.Builtin "Text.right"
|
||||
in (r, Nothing, alignmentT, prefixes ["right", "Text"])
|
||||
, let r = R.Builtin "Text.center"
|
||||
in (r, Nothing, alignmentT, prefixes ["center", "Text"])
|
||||
, let r = R.Builtin "Text.justify"
|
||||
in (r, Nothing, alignmentT, prefixes ["center", "Text"])
|
||||
|
||||
, let r = R.Builtin "View.cell"
|
||||
in (r, Nothing, Type.forall1 $ \a -> view a `arr` (a `arr` cellT), prefix "cell")
|
||||
, let r = R.Builtin "View.color"
|
||||
in (r, Nothing, colorT `arr` view cellT, prefix "color")
|
||||
, let r = R.Builtin "View.embed"
|
||||
in (r, Nothing, view cellT, prefix "embed")
|
||||
, let r = R.Builtin "View.fit-width"
|
||||
in (r, Nothing, Type.forall1 $ \a -> distanceT `arr` view a, prefix "fit-width")
|
||||
, let r = R.Builtin "View.function1"
|
||||
in ( r
|
||||
, Nothing
|
||||
, Type.forall2 $ \a b -> (cellT `arr` cellT) `arr` view (a `arr` b)
|
||||
, prefix "function1" )
|
||||
, let r = R.Builtin "View.hide"
|
||||
in (r, Nothing, Type.forall1 view, prefix "hide")
|
||||
, let r = R.Builtin "View.horizontal"
|
||||
in (r, Nothing, view (vec cellT), prefix "horizontal")
|
||||
, let r = R.Builtin "View.reactive"
|
||||
in (r, Nothing, Type.forall1 $ \a -> view a `arr` view a, prefix "reactive")
|
||||
, let r = R.Builtin "View.source"
|
||||
in (r, Nothing, Type.forall1 $ \a -> view a, prefix "source")
|
||||
, let r = R.Builtin "View.spacer"
|
||||
in (r, Nothing, distanceT `arr` (num `arr` view unitT), prefix "spacer")
|
||||
, let r = R.Builtin "View.swatch"
|
||||
in (r, Nothing, view colorT, prefix "swatch")
|
||||
, let r = R.Builtin "View.text"
|
||||
in (r, Nothing, styleT `arr` view str, prefix "text")
|
||||
, let r = R.Builtin "View.textbox"
|
||||
in (r, Nothing, alignmentT `arr` (distanceT `arr` (styleT `arr` view str)), prefix "textbox")
|
||||
, let r = R.Builtin "View.vertical"
|
||||
in (r, Nothing, view (vec cellT), prefix "vertical")
|
||||
, let r = R.Builtin "View.view"
|
||||
in (r, Nothing, Type.forall1 $ \a -> view a `arr` (a `arr` a), prefix "view")
|
||||
]
|
||||
where
|
||||
str = Type.Unit Type.String
|
||||
num = Type.Unit Type.Number
|
||||
alignmentT = Type.Unit (Type.Ref (R.Builtin "Alignment"))
|
||||
arr = Type.Arrow
|
||||
cellT = Type.Unit (Type.Ref (R.Builtin "Cell"))
|
||||
colorT = Type.Unit (Type.Ref (R.Builtin "Color"))
|
||||
distanceT = Type.Unit Type.Distance
|
||||
num = Type.Unit Type.Number
|
||||
numOpTyp = num `arr` (num `arr` num)
|
||||
strOpTyp = str `arr` (str `arr` str)
|
||||
styleT = Type.Unit (Type.Ref (R.Builtin "Text.Style"))
|
||||
st = strOpTyp
|
||||
nf r n = I.Primop n $ pure . foldl' Term.App (Term.Ref r)
|
||||
str = Type.Unit Type.String
|
||||
strOpTyp = str `arr` (str `arr` str)
|
||||
unitT = Type.Unit (Type.Ref (R.Builtin "Unit"))
|
||||
vec a = Type.App (Type.Unit Type.Vector) a
|
||||
view a = Type.App (Type.Unit (Type.Ref (R.Builtin "View"))) a
|
||||
|
||||
opl n s = Metadata Metadata.Term
|
||||
(Metadata.Names [Metadata.Symbol s Metadata.InfixL n ])
|
||||
[]
|
||||
Nothing
|
||||
prefix s = Metadata Metadata.Term
|
||||
(Metadata.Names [Metadata.Symbol s Metadata.Prefix 9])
|
||||
|
||||
prefix s = prefixes [s]
|
||||
|
||||
prefixes s = Metadata Metadata.Term
|
||||
(Metadata.Names (map (\s -> Metadata.Symbol s Metadata.Prefix 9) s))
|
||||
[]
|
||||
Nothing
|
||||
|
||||
@ -93,7 +149,7 @@ store :: Store IO
|
||||
store = F.store "store"
|
||||
|
||||
eval :: Eval (N.Noted IO)
|
||||
eval = I.eval (M.fromList $ map (\(k,v,_,_) -> (k,v)) builtins)
|
||||
eval = I.eval (M.fromList [ (k,v) | (k,Just v,_,_) <- builtins ])
|
||||
|
||||
readTerm :: Hash -> N.Noted IO Term
|
||||
readTerm h = Store.readTerm store h
|
||||
|
||||
Loading…
Reference in New Issue
Block a user