0 | module Web.MVC.Canvas.Scene
  1 |
  2 | import Control.Monad.Either.Extra
  3 | import JS
  4 | import Web.MVC.Canvas.Shape
  5 | import Web.MVC.Canvas.Style
  6 | import Web.MVC.Canvas.Transformation
  7 | import Web.Html
  8 |
  9 | %default total
 10 |
 11 | --------------------------------------------------------------------------------
 12 | --          Text Metrics
 13 | --------------------------------------------------------------------------------
 14 |
 15 | %foreign "browser:lambda:(x,a)=>x.measureText(a)"
 16 | prim__measure : CanvasRenderingContext2D -> String -> PrimIO TextMetrics
 17 |
 18 | export
 19 | %foreign "browser:lambda:x=>x.actualBoundingBoxAscent"
 20 | actualBoundingBoxAscent : TextMetrics -> Double
 21 |
 22 | export
 23 | %foreign "browser:lambda:x=>x.actualBoundingBoxDescent"
 24 | actualBoundingBoxDescent : TextMetrics -> Double
 25 |
 26 | export
 27 | %foreign "browser:lambda:x=>x.actualBoundingBoxLeft"
 28 | actualBoundingBoxLeft : TextMetrics -> Double
 29 |
 30 | export
 31 | %foreign "browser:lambda:x=>x.actualBoundingBoxRight"
 32 | actualBoundingBoxRight : TextMetrics -> Double
 33 |
 34 | export
 35 | %foreign "browser:lambda:x=>x.alphabeticBaseline"
 36 | alphabeticBaseline : TextMetrics -> Double
 37 |
 38 | export
 39 | %foreign "browser:lambda:x=>x.emHeightAscent"
 40 | emHeightAscent : TextMetrics -> Double
 41 |
 42 | export
 43 | %foreign "browser:lambda:x=>x.emHeightDescent"
 44 | emHeightDescent : TextMetrics -> Double
 45 |
 46 | export
 47 | %foreign "browser:lambda:x=>x.fontBoundingBoxAscent"
 48 | fontBoundingBoxAscent : TextMetrics -> Double
 49 |
 50 | export
 51 | %foreign "browser:lambda:x=>x.fontBoundingBoxDescent"
 52 | fontBoundingBoxDescent : TextMetrics -> Double
 53 |
 54 | export
 55 | %foreign "browser:lambda:x=>x.hangingBaseline"
 56 | hangingBaseline : TextMetrics -> Double
 57 |
 58 | export
 59 | %foreign "browser:lambda:x=>x.ideographicBaseline"
 60 | ideographicBaseline : TextMetrics -> Double
 61 |
 62 | export
 63 | %foreign "browser:lambda:x=>x.width"
 64 | width : TextMetrics -> Double
 65 |
 66 | %foreign "browser:lambda:(c,d,a,b,f,s)=>{d0 = c.direction; b0 = c.textBaseline; a0 = c.textAlign; f0 = c.font; c.font = f; c.direction = d; c.textBaseline = b; c.textAlign = a; res = c.measureText(s); c.font = f0; c.direction = d0; c.textBaseline = b0; c.textAlign = a0; return res}"
 67 | prim__measureText :
 68 |      CanvasRenderingContext2D
 69 |   -> (dir, align, baseline, font, text : String)
 70 |   -> TextMetrics
 71 |
 72 | --------------------------------------------------------------------------------
 73 | --          Scene
 74 | --------------------------------------------------------------------------------
 75 |
 76 | public export
 77 | data Scene : Type where
 78 |   S1 : (fs : List Style) -> (tr : Transformation) -> (shape : Shape) -> Scene
 79 |   SM : (fs : List Style) -> (tr : Transformation) -> List Scene -> Scene
 80 |
 81 | --------------------------------------------------------------------------------
 82 | --          IO
 83 | --------------------------------------------------------------------------------
 84 |
 85 | export
 86 | applyAll : CanvasRenderingContext2D -> List Scene -> JSIO ()
 87 |
 88 | export
 89 | apply : CanvasRenderingContext2D -> Scene -> JSIO ()
 90 |
 91 | applyAll ctxt = assert_total $ traverseList_ (apply ctxt)
 92 |
 93 | apply ctxt (S1 fs tr shape) = do
 94 |   save    ctxt
 95 |   traverseList_ (apply ctxt) fs
 96 |   apply   ctxt tr
 97 |   apply   ctxt shape
 98 |   restore ctxt
 99 |
100 | apply ctxt (SM fs tr xs) = do
101 |   save     ctxt
102 |   traverseList_ (apply ctxt) fs
103 |   apply    ctxt tr
104 |   applyAll ctxt xs
105 |   restore  ctxt
106 |
107 | ||| Utility for computing `TextMetrics`.
108 | export
109 | record TextMeasure where
110 |   [noHints]
111 |   constructor TM
112 |   measure_ : (dir, align, bl, font, text : String) -> TextMetrics
113 |
114 | ||| Compute the `TextMetrics` for the given text in the given font.
115 | export %inline
116 | measureText :
117 |      {auto m : TextMeasure}
118 |   -> CanvasDirection
119 |   -> CanvasTextAlign
120 |   -> CanvasTextBaseline
121 |   -> (font,text : String)
122 |   -> TextMetrics
123 | measureText d a b f t = m.measure_ (show d) (show a) (show b) f t
124 |
125 | ||| Supplies the given function with a `TextMeasure` implicit, derived
126 | ||| from the given rendering context.
127 | export %inline
128 | withMetrics : CanvasRenderingContext2D -> (TextMeasure => a) -> a
129 | withMetrics cd f = f @{TM $ prim__measureText cd}
130 |
131 | ||| Alternative version of `apply` for those cases where we need to
132 | ||| work with text metrics.
133 | export
134 | applyWithMetrics : CanvasRenderingContext2D -> (TextMeasure => Scene) -> JSIO ()
135 | applyWithMetrics cd f = withMetrics cd $ apply cd f
136 |