term rendering with dynamic reflow seems to be working

This commit is contained in:
Paul Chiusano 2014-09-02 11:22:43 -04:00
parent e3d1e9424a
commit bae33579c2
4 changed files with 57 additions and 59 deletions

View File

@ -1,5 +1,9 @@
module Main where module Main where
import Array
import Set
import Unison.Path (Path)
import Unison.Hash (Hash)
import Unison.Styles as S import Unison.Styles as S
import Unison.Layout as UL import Unison.Layout as UL
import Unison.Term as L import Unison.Term as L
@ -11,46 +15,25 @@ import Graphics.Input(..)
import Graphics.Input.Field(..) import Graphics.Input.Field(..)
import Window import Window
-- each cell will consist of a single Element entry : Input (Maybe (Hash,Path))
-- 'standard' input boxes not really entry = input Nothing
-- flexible enough, since depending on
-- scope, are overwriting different region of
-- syntax tree
{-
source : Term -> Element
idea: have just one input box, at the top nums : L.Term
alternately, place input box above selection, nums = let f x = L.Lit (L.Number (toFloat x))
with a caret pointing down in L.Lit (L.Vector (Array.fromList (map f [0..20])))
f x = [x + 1 + 2 + 3] expr = L.App (L.App (L.Ref "foo") nums) (L.Ref "baz")
-------------------
| |
- ----------------
\/
f x = [x + 1 + 2 + 3]
need to create an input box
-}
entry : Input Content scene : Int -> (Maybe (Hash,Path)) -> Element
entry = input noContent scene w p =
flow down
midnightBlue = rgb 44 62 80 [ S.codeText ("path: " ++ show p)
turquoise = rgb 26 188 156 , L.render expr
greenSea = rgb 22 160 133 { handle = entry.handle
, key = "bar"
fieldStyle = , highlighted = []
{ padding = { left=8, right=8, top=11, bottom=12 } , availableWidth = w
, outline = { color=midnightBlue, width=uniformly 3, radius=0 } , metadata h = MD.anonymousTerm } ]
, highlight = noHighlight
, style = let t = Text.defaultStyle
in { t | typeface <- ["Lato", "latin"], height <- Just 16 } }
fld = field fieldStyle
main : Signal Element main : Signal Element
main = main = scene <~ Window.width ~ entry.signal
let scene (w,h) content = container w h middle (f content)
f content = width 100 (fld entry.handle id "" content)
in scene <~ Window.dimensions ~ entry.signal

View File

@ -23,6 +23,9 @@ type Metadata = {
annotation : H.Hash annotation : H.Hash
} }
anonymousTerm : Metadata
anonymousTerm = Metadata Term [] M.empty Nothing "unknown"
firstSymbol : String -> Metadata -> Symbol firstSymbol : String -> Metadata -> Symbol
firstSymbol defaultName md = case md.names of firstSymbol defaultName md = case md.names of
[] -> { name = defaultName, fixity = Prefix, precedence = 9 } [] -> { name = defaultName, fixity = Prefix, precedence = 9 }

View File

@ -32,27 +32,41 @@ outline2 : Color -> Element -> Element
outline2 c e = outline2 c e =
container (widthOf e + 6) (heightOf e + 6) (topLeftAt (absolute 3) (absolute 3)) e |> color c container (widthOf e + 6) (heightOf e + 6) (topLeftAt (absolute 3) (absolute 3)) e |> color c
cell : String -> Element pad : Int -> Int -> Element -> Element
cell x = codeText (" " ++ x ++ " ") |> color clouds pad hpad vpad e =
container (widthOf e + hpad*2) (heightOf e + vpad*2) (topLeftAt (absolute hpad) (absolute vpad)) e
-- vertically center each cell in the row
row : [Element] -> [Element]
row es = case es of
[] -> [empty]
_ -> let maxh = maximum (map heightOf es)
cell e = if heightOf e == maxh then e else container (widthOf e) maxh middle e
in map cell es
cell : Element -> Element
cell = pad 10 2
cells : Element -> [Element] -> Element cells : Element -> [Element] -> Element
cells ifEmpty xs = cells ifEmpty xs =
let space = cell " " let space = cell (codeText " ")
in if isEmpty xs in if isEmpty xs
then ifEmpty then ifEmpty
else intersperse (spacer 1 (heightOf space) |> color silver) xs else intersperse (spacer 1 (heightOf space) |> color silver) (map cell (row xs))
|> flow right |> flow right
|> outline2 silver |> fill white
|> outline silver
verticalCells : Element -> [Element] -> Element verticalCells : Element -> [Element] -> Element
verticalCells ifEmpty xs = verticalCells ifEmpty xs =
if isEmpty xs if isEmpty xs
then ifEmpty then ifEmpty
else let maxw = maximum (map widthOf xs) + 1 else let cells = map cell xs
in intersperse (spacer maxw 1 |> color silver) xs maxw = maximum (map widthOf cells) + 1
in intersperse (spacer maxw 1 |> color silver) (map cell xs)
|> flow down |> flow down
|> fill clouds |> fill white
|> outline2 silver |> outline silver
-- http://flatuicolors.com/ -- http://flatuicolors.com/
turquoise = rgb 26 188 156 turquoise = rgb 26 188 156

View File

@ -7,6 +7,7 @@ import Dict (Dict)
import Json import Json
import Set import Set
import Set (Set) import Set (Set)
import String
import Graphics.Element as Element import Graphics.Element as Element
import Graphics.Input (Handle, hoverable) import Graphics.Input (Handle, hoverable)
import Text(..) import Text(..)
@ -27,7 +28,7 @@ import Unison.Type as T
data Literal data Literal
= Number Float = Number Float
| String String | Str String
| Vector (Array Term) | Vector (Array Term)
data Term data Term
@ -42,26 +43,28 @@ data Term
render : Term -- term to render render : Term -- term to render
-> { handle : Handle (Maybe (Hash, Path)) -> { handle : Handle (Maybe (Hash, Path))
, key : Hash , key : Hash
, highlighted : Set Path , highlighted : [Path]
, availableWidth : Int , availableWidth : Int
, metadata : Hash -> Metadata } , metadata : Hash -> Metadata }
-> Element -> Element
render expr env = render expr env =
let let
md = env.metadata env.key md = env.metadata env.key
msg path b = if b then Just (env.key, path) else Nothing
go : Bool -> Int -> Int -> { path : Path, term : Term } -> Element go : Bool -> Int -> Int -> { path : Path, term : Term } -> Element
go allowBreak ambientPrec availableWidth cur = go allowBreak ambientPrec availableWidth cur =
case cur.term of case cur.term of
Var n -> hoverable env.handle (msg cur.path) (codeText (Metadata.resolveLocal md cur.path n).name) Var n -> hoverable env.handle (msg cur.path) (codeText (Metadata.resolveLocal md cur.path n).name)
Ref h -> hoverable env.handle (msg cur.path) (codeText (Metadata.firstName h (env.metadata h))) Ref h -> hoverable env.handle (msg cur.path) (codeText (Metadata.firstName h (env.metadata h)))
Con h -> hoverable env.handle (msg cur.path) (codeText (Metadata.firstName h (env.metadata h))) Con h -> hoverable env.handle (msg cur.path) (codeText (Metadata.firstName h (env.metadata h)))
Lit (Number n) -> hoverable env.handle (msg cur.path) (codeText (show n)) Lit (Number n) -> hoverable env.handle (msg cur.path) (codeText (String.show n))
Lit (String s) -> hoverable env.handle (msg cur.path) (codeText s) Lit (Str s) -> hoverable env.handle (msg cur.path) (codeText s)
_ -> case break env.key env.metadata cur.path cur.term of _ -> case break env.key env.metadata cur.path cur.term of
Prefix f args -> Prefix f args ->
let f' = go False 9 availableWidth f let f' = go False 9 availableWidth f
lines = f' :: map (go False 10 0) args lines = f' :: map (go False 10 0) args
unbroken = paren (ambientPrec > 9) cur.path (flow right (intersperse space lines)) unbroken = paren (ambientPrec > 9) cur.path (flow right (intersperse space lines |> Styles.row))
in if not allowBreak || widthOf unbroken < availableWidth in if not allowBreak || widthOf unbroken < availableWidth
then unbroken then unbroken
else let args' = map (go True 10 (availableWidth - indentWidth)) args |> flow down else let args' = map (go True 10 (availableWidth - indentWidth)) args |> flow down
@ -97,8 +100,6 @@ render expr env =
else flow down [argLayout, space2 `beside` go True 0 (availableWidth - indentWidth) body] else flow down [argLayout, space2 `beside` go True 0 (availableWidth - indentWidth) body]
|> paren (ambientPrec > 0) cur.path |> paren (ambientPrec > 0) cur.path
msg path b = if b then Just (env.key, path) else Nothing
paren : Bool -> Path -> Element -> Element paren : Bool -> Path -> Element -> Element
paren parenthesize path e = paren parenthesize path e =
if parenthesize if parenthesize
@ -170,18 +171,15 @@ break hash md path expr =
_ -> Lambda [{path = path, term = expr }] { path = path `push` Body, term = body } _ -> Lambda [{path = path, term = expr }] { path = path `push` Body, term = body }
_ -> prefix expr [] path _ -> prefix expr [] path
todo : a
todo = todo
parseLiteral : Parser Literal parseLiteral : Parser Literal
parseLiteral = P.union' <| \t -> parseLiteral = P.union' <| \t ->
if | t == "Number" -> P.map Number P.number if | t == "Number" -> P.map Number P.number
| t == "String" -> P.map String P.string | t == "String" -> P.map Str P.string
| t == "Vector" -> P.map (Vector . Array.fromList) (P.array parseTerm) | t == "Vector" -> P.map (Vector . Array.fromList) (P.array parseTerm)
jsonifyLiteral l = case l of jsonifyLiteral l = case l of
Number n -> J.tag' "Number" J.number n Number n -> J.tag' "Number" J.number n
String s -> J.tag' "String" J.string s Str s -> J.tag' "String" J.string s
Vector es -> J.tag' "Vector" (J.contramap Array.toList (J.array jsonifyTerm)) es Vector es -> J.tag' "Vector" (J.contramap Array.toList (J.array jsonifyTerm)) es
parseTerm : Parser Term parseTerm : Parser Term