├── Setup.hs ├── cabal.project ├── examples ├── HelloWorld.hs ├── expr.morte └── expr.svg ├── src ├── layout │ └── Source │ │ └── Layout │ │ ├── Cairo.hs │ │ ├── Cairo │ │ ├── Prim.hs │ │ ├── Prim │ │ │ ├── Color.hs │ │ │ ├── Circle.hs │ │ │ ├── Rect.hs │ │ │ ├── Curve.hs │ │ │ └── Text.hs │ │ └── Element.hs │ │ ├── Inj.hs │ │ ├── Combinators.hs │ │ ├── NonNegative.hs │ │ └── Core.hs ├── driver │ ├── Source │ │ ├── Input │ │ │ └── KeyCode.hs │ │ ├── Input.hs │ │ ├── Phaser.hs │ │ └── NewGen.hs │ └── Source.hs ├── bin │ ├── Hask.hs │ ├── Foundry.hs │ ├── SdamToSvg.hs │ ├── MorteToSdam.hs │ └── HaskellToSdam.hs ├── plugin │ └── Source │ │ ├── Plugin.hs │ │ └── Plugin │ │ └── Precedence.hs ├── sdam │ └── Sdam │ │ ├── Printer.hs │ │ ├── Parser.hs │ │ ├── Core.hs │ │ ├── Syn.hs │ │ └── Validator.hs ├── lang │ ├── morte │ │ └── Source │ │ │ └── Language │ │ │ └── Morte.hs │ └── haskell │ │ └── Source │ │ └── Language │ │ └── Haskell.hs └── foundry.cabal ├── .github └── workflows │ └── ci.yml ├── .gitignore ├── Makefile ├── README.md ├── flake.lock └── flake.nix /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | src/foundry.cabal 3 | 4 | allow-newer: 5 | morte:optparse-applicative 6 | -------------------------------------------------------------------------------- /examples/HelloWorld.hs: -------------------------------------------------------------------------------- 1 | module Source.Example.HelloWorld where 2 | 3 | main :: IO () 4 | main = putStrLn greeting 5 | 6 | greeting :: String 7 | greeting = "Hello, World!" 8 | -------------------------------------------------------------------------------- /src/layout/Source/Layout/Cairo.hs: -------------------------------------------------------------------------------- 1 | module Source.Layout.Cairo 2 | ( module Source.Layout.Core, 3 | module Source.Layout.Cairo.Element, 4 | module Source.Layout.Cairo.Prim, 5 | ) where 6 | 7 | import Source.Layout.Core 8 | import Source.Layout.Cairo.Element 9 | import Source.Layout.Cairo.Prim 10 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: 3 | pull_request: 4 | push: 5 | branches: ["master"] 6 | 7 | jobs: 8 | check: 9 | runs-on: [self-hosted, nix] 10 | steps: 11 | - uses: actions/checkout@v2 12 | 13 | - name: Check Nix flake 14 | run: nix flake check -L 15 | 16 | - name: Build Nix flake 17 | run: nix build 18 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Cabal 2 | dist 3 | dist-newstyle 4 | .cabal-sandbox/ 5 | cabal.sandbox.config 6 | cabal.project.local 7 | .ghc.environment* 8 | 9 | # Profiling 10 | *.prof 11 | 12 | # Stack 13 | .stack-work 14 | 15 | # Emacs 16 | TAGS 17 | .dir-locals.el 18 | 19 | # Vim 20 | tags 21 | *.swp 22 | 23 | # Agda 24 | *.agdai 25 | MAlonzo 26 | 27 | # Sdam 28 | *.sd 29 | 30 | # Nix 31 | result 32 | -------------------------------------------------------------------------------- /examples/expr.morte: -------------------------------------------------------------------------------- 1 | λ(x : ∀(Nat : *) → ∀(Succ : Nat → Nat) → ∀(Zero : Nat) → Nat) → x (∀(Bool : *) → ∀(True : Bool) → ∀(False : Bool) → Bool) (λ(x : ∀(Bool : *) → ∀(True : Bool) → ∀(False : Bool) → Bool) → x (∀(Bool : *) → ∀(True : Bool) → ∀(False : Bool) → Bool) (λ(Bool : *) → λ(True : Bool) → λ(False : Bool) → False) (λ(Bool : *) → λ(True : Bool) → λ(False : Bool) → True)) (λ(Bool : *) → λ(True : Bool) → λ(False : Bool) → True) 2 | -------------------------------------------------------------------------------- /src/driver/Source/Input/KeyCode.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wno-missing-pattern-synonym-signatures #-} 2 | 3 | module Source.Input.KeyCode where 4 | 5 | pattern Backspace = 65288 6 | 7 | pattern Delete = 65535 8 | 9 | pattern Enter = 65293 10 | 11 | pattern ArrowLeft = 65361 12 | 13 | pattern ArrowRight = 65363 14 | 15 | pattern ArrowUp = 65362 16 | 17 | pattern ArrowDown = 65364 18 | 19 | pattern Escape = 65307 20 | 21 | pattern Space = 32 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build dev/build dev/watch dev/reset-db dev/run fmt tags clean 2 | 3 | build: 4 | cabal v2-build --ghc-options "-Werror -O3" 5 | 6 | dev/build: 7 | cabal v2-build 8 | 9 | dev/watch: 10 | watchman-make -p '*.cabal' 'src/**/*.hs' -t dev/build 11 | 12 | dev/run: 13 | cabal v2-run -- foundry "./expr.morte" 14 | 15 | fmt: 16 | ormolu -c --mode inplace `find src -name "*.hs"` 17 | 18 | tags: 19 | fast-tags -R src 20 | 21 | clean: 22 | cabal v2-clean 23 | -------------------------------------------------------------------------------- /src/layout/Source/Layout/Cairo/Prim.hs: -------------------------------------------------------------------------------- 1 | module Source.Layout.Cairo.Prim 2 | ( module Source.Layout.Cairo.Prim.Color, 3 | module Source.Layout.Cairo.Prim.Text, 4 | module Source.Layout.Cairo.Prim.Rect, 5 | module Source.Layout.Cairo.Prim.Curve, 6 | module Source.Layout.Cairo.Prim.Circle, 7 | ) where 8 | 9 | import Source.Layout.Cairo.Prim.Color 10 | import Source.Layout.Cairo.Prim.Text 11 | import Source.Layout.Cairo.Prim.Rect 12 | import Source.Layout.Cairo.Prim.Curve 13 | import Source.Layout.Cairo.Prim.Circle 14 | -------------------------------------------------------------------------------- /src/driver/Source/Input.hs: -------------------------------------------------------------------------------- 1 | module Source.Input 2 | ( Modifier (..), 3 | KeyCode, 4 | keyChar, 5 | InputEvent (..), 6 | ) 7 | where 8 | 9 | import Data.Word 10 | import qualified Graphics.UI.Gtk as Gtk 11 | 12 | data Modifier = Control | Shift | Alt 13 | deriving (Eq, Show) 14 | 15 | type KeyCode = Word32 16 | 17 | keyChar :: KeyCode -> Maybe Char 18 | keyChar = Gtk.keyToChar 19 | 20 | data InputEvent 21 | = KeyPress [Modifier] KeyCode 22 | | KeyRelease [Modifier] KeyCode 23 | | PointerMotion Int Int 24 | | ButtonPress 25 | deriving (Eq, Show) 26 | -------------------------------------------------------------------------------- /src/bin/Hask.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Sdam.Parser (pValue, parse) 4 | import Source 5 | import Source.Language.Haskell 6 | import System.Environment (getArgs) 7 | import System.Exit (die) 8 | import Text.Megaparsec as Megaparsec (errorBundlePretty) 9 | 10 | main :: IO () 11 | main = do 12 | mParsedValue <- getArgs >>= \case 13 | [filepath] -> do 14 | content <- readFile filepath 15 | case parse pValue filepath content of 16 | Left e -> die (Megaparsec.errorBundlePretty e) 17 | Right a -> return (Just a) 18 | [] -> return Nothing 19 | _ -> die "Usage: hask FILE.sd" 20 | runSource haskellPlugin mParsedValue 21 | -------------------------------------------------------------------------------- /src/bin/Foundry.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Sdam.Parser (pValue, parse) 4 | import Source 5 | import Source.Language.Morte 6 | import System.Environment (getArgs) 7 | import System.Exit (die) 8 | import Text.Megaparsec as Megaparsec (errorBundlePretty) 9 | 10 | main :: IO () 11 | main = do 12 | mParsedValue <- getArgs >>= \case 13 | [filepath] -> do 14 | content <- readFile filepath 15 | case parse pValue filepath content of 16 | Left e -> die (Megaparsec.errorBundlePretty e) 17 | Right a -> return (Just a) 18 | [] -> return Nothing 19 | _ -> die "Usage: foundry FILE.sd" 20 | runSource mortePlugin mParsedValue 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Foundry 2 | 3 | Foundry is a Morte IDE based on Source. 4 | 5 | Implementation status: 6 | 7 | * [x] rendering expressions 8 | * [x] basic navigation 9 | * [x] editing expressions 10 | * [ ] interactive evaluation 11 | * [ ] auto-completion 12 | 13 | ![Rendering Morte](examples/expr.svg) 14 | 15 | ## Getting Started 16 | 17 | ``` 18 | $ nix build 19 | $ result/bin/morte-to-sdam "./examples/expr.morte" > expr.sd 20 | $ result/bin/sdam-to-svg --morte expr.sd 21 | $ result/bin/foundry expr.sd 22 | ``` 23 | 24 | ## Tooling 25 | 26 | ``` 27 | $ nix develop -c $SHELL 28 | $ make tags 29 | $ make fmt 30 | ``` 31 | 32 | ## SVG Optimization 33 | 34 | ``` 35 | $ nix shell nixpkgs#nodePackages.svgo 36 | $ svgo expr.svg 37 | ``` 38 | -------------------------------------------------------------------------------- /src/plugin/Source/Plugin.hs: -------------------------------------------------------------------------------- 1 | module Source.Plugin 2 | ( module Source.Plugin.Precedence, 3 | module Sdam.Syn, 4 | module Sdam.Validator, 5 | ShapeName (..), 6 | Plugin (..), 7 | ) 8 | where 9 | 10 | import Data.HashMap.Strict (HashMap) 11 | import Data.Primitive.Array (Array) 12 | import Data.Text (Text) 13 | import Sdam.Syn (SynShape) 14 | import Sdam.Validator (Schema (..), mkTyUnion) 15 | import Source.Plugin.Precedence 16 | 17 | data ShapeName 18 | = ShapeName 19 | { shapeName :: Text, 20 | shapeFieldNames :: Array Text 21 | } 22 | 23 | data Plugin 24 | = Plugin 25 | { pluginSchema :: Schema, 26 | pluginPrecInfo :: HashMap SynShape (Array PrecPredicate), 27 | pluginShapeNames :: HashMap SynShape ShapeName 28 | } 29 | -------------------------------------------------------------------------------- /src/layout/Source/Layout/Cairo/Prim/Color.hs: -------------------------------------------------------------------------------- 1 | module Source.Layout.Cairo.Prim.Color 2 | ( Color(..), 3 | rgb, 4 | grayscale, 5 | setSourceColor 6 | ) where 7 | 8 | import Data.Word 9 | import Data.Hashable 10 | import GHC.Generics (Generic) 11 | 12 | import qualified Graphics.Rendering.Cairo as Cairo 13 | 14 | import Source.Layout.Inj 15 | 16 | data Color = 17 | -- true color (24bit) 18 | RGB Word8 Word8 Word8 19 | deriving (Eq, Ord, Show, Generic) 20 | 21 | instance Hashable Color 22 | 23 | instance p ~ Color => Inj p Color 24 | 25 | rgb :: Inj Color a => Word8 -> Word8 -> Word8 -> a 26 | rgb r g b = inj (RGB r g b) 27 | 28 | grayscale :: Inj Color a => Word8 -> a 29 | grayscale a = rgb a a a 30 | 31 | setSourceColor :: Color -> Cairo.Render () 32 | setSourceColor (RGB r g b) = 33 | Cairo.setSourceRGB (toDouble r) (toDouble g) (toDouble b) 34 | where 35 | toDouble x = fromIntegral x / fromIntegral (maxBound :: Word8) 36 | -------------------------------------------------------------------------------- /src/sdam/Sdam/Printer.hs: -------------------------------------------------------------------------------- 1 | module Sdam.Printer 2 | ( 3 | -- Value 4 | rValue, 5 | RenderValue(..), 6 | 7 | -- Path 8 | rPath, 9 | 10 | -- Running 11 | render 12 | ) where 13 | 14 | import Prelude hiding ((<>)) 15 | 16 | import Data.List 17 | import Text.PrettyPrint 18 | 19 | import Sdam.Core 20 | 21 | rSynShape :: SynShape -> Doc 22 | rSynShape = text . concatMap escape . flattenSynShape 23 | where 24 | escape '\n' = "\\n" 25 | escape c 26 | | needsEscape c = ['\\', c] 27 | | otherwise = [c] 28 | needsEscape c = 29 | c `elem` ("\\\n " :: [Char]) 30 | 31 | newtype RenderValue = RenderValue (Syn RenderValue) 32 | deriving newtype Show 33 | 34 | rValue :: RenderValue -> Doc 35 | rValue (RenderValue syn) = 36 | hang (rSynShape (synShape syn)) 2 (sep (map rValue (synFields syn))) 37 | 38 | rPath :: Path -> Doc 39 | rPath (Path ps) = 40 | hsep $ 41 | intersperse (char '/') $ 42 | map rPathSegment ps 43 | 44 | rPathSegment :: PathSegment -> Doc 45 | rPathSegment (PathSegment shape i) = 46 | rSynShape shape <+> brackets (rIndex i) 47 | 48 | rIndex :: Index -> Doc 49 | rIndex = int . indexToInt 50 | -------------------------------------------------------------------------------- /src/layout/Source/Layout/Cairo/Prim/Circle.hs: -------------------------------------------------------------------------------- 1 | module Source.Layout.Cairo.Prim.Circle (circle) where 2 | 3 | import Numeric.Natural 4 | import Data.Foldable (for_) 5 | 6 | import qualified Graphics.Rendering.Cairo as Cairo 7 | 8 | import Source.Layout.Inj 9 | import Source.Layout.NonNegative 10 | import Source.Layout.Core 11 | 12 | import Source.Layout.Cairo.Prim.Color 13 | import Source.Layout.Cairo.Element 14 | 15 | circle :: 16 | forall g a. 17 | Inj (CairoElement g) a => 18 | g Color -> 19 | g (Maybe (NonNegative Double)) -> 20 | Natural -> 21 | a 22 | circle gcolor gmthickness diameter = 23 | inj CairoElement 24 | { cairoElementExtents = extents, 25 | cairoElementBaseline = NoBaseline, 26 | cairoElementRender = render } 27 | where 28 | extents = Extents diameter diameter 29 | 30 | render :: Offset -> CairoRender g 31 | render offset = CairoRender $ \getG -> do 32 | let (Offset (fromIntegral -> x) (fromIntegral -> y)) = offset 33 | setSourceColor $ getG gcolor 34 | let r = fromIntegral diameter / 2 35 | for_ (getG gmthickness) $ \thck -> do 36 | Cairo.setFillRule Cairo.FillRuleEvenOdd 37 | Cairo.arc (r + x) (r + y) (r - getNonNegative thck) 0 (2 * pi) 38 | Cairo.arc (r + x) (r + y) r 0 (2 * pi) 39 | Cairo.fill 40 | -------------------------------------------------------------------------------- /src/driver/Source/Phaser.hs: -------------------------------------------------------------------------------- 1 | module Source.Phaser 2 | ( Phaser (..), 3 | newPhaser, 4 | ) 5 | where 6 | 7 | import Control.Concurrent 8 | import Control.Exception 9 | import Control.Monad 10 | import Data.IORef 11 | import Data.Typeable 12 | 13 | data Phaser st 14 | = Phaser 15 | { phaserCurrent :: IO st, 16 | phaserStop :: IO (), 17 | phaserReset :: st -> IO () 18 | } 19 | 20 | data TimerReset st = TimerReset st 21 | 22 | instance Show (TimerReset st) where 23 | show _ = "TimerReset" 24 | 25 | instance Typeable st => Exception (TimerReset st) 26 | 27 | newPhaser :: 28 | forall st. 29 | Typeable st => 30 | Int -> 31 | st -> 32 | (st -> st) -> 33 | (st -> IO ()) -> 34 | IO (Phaser st) 35 | newPhaser d initSt transition hook = do 36 | ref <- newIORef initSt 37 | tId <- forkIO 38 | $ mask 39 | $ \restore -> 40 | forever $ do 41 | a <- readIORef ref 42 | (b, a') <- restore $ 43 | try (threadDelay d) >>= \case 44 | Left (TimerReset st) -> return (False, st) 45 | Right () -> return (True, transition a) 46 | atomicWriteIORef ref a' 47 | when b (hook a') 48 | return Phaser 49 | { phaserCurrent = readIORef ref, 50 | phaserStop = killThread tId, 51 | phaserReset = \st -> throwTo tId (TimerReset st) 52 | } 53 | -------------------------------------------------------------------------------- /src/layout/Source/Layout/Cairo/Element.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StrictData #-} 2 | 3 | module Source.Layout.Cairo.Element 4 | ( CairoElement(..), 5 | cairoPositionedElementRender, 6 | CairoRender(..) 7 | ) where 8 | 9 | import qualified Graphics.Rendering.Cairo as Cairo 10 | 11 | import Source.Layout.Inj 12 | import Source.Layout.Core 13 | 14 | -- A monadic action to draw a picture. 15 | newtype CairoRender g = 16 | CairoRender { cairoRender :: (forall x. g x -> x) -> Cairo.Render () } 17 | 18 | instance Semigroup (CairoRender g) where 19 | r1 <> r2 = 20 | CairoRender $ \getG -> do 21 | cairoRender r1 getG 22 | cairoRender r2 getG 23 | 24 | instance Monoid (CairoRender g) where 25 | mempty = CairoRender $ \_ -> return () 26 | 27 | data CairoElement g = 28 | CairoElement 29 | { cairoElementExtents :: Extents, 30 | cairoElementBaseline :: Baseline, 31 | cairoElementRender :: Offset -> CairoRender g 32 | } 33 | 34 | cairoPositionedElementRender :: Positioned (CairoElement g) -> CairoRender g 35 | cairoPositionedElementRender (At o e) = cairoElementRender e o 36 | 37 | instance HasExtents (CairoElement g) where 38 | extentsOf = cairoElementExtents 39 | 40 | instance HasBaseline (CairoElement g) where 41 | baselineOf = cairoElementBaseline 42 | 43 | instance g1 ~ g2 => Inj (CairoElement g1) (CairoElement g2) where 44 | inj = id 45 | -------------------------------------------------------------------------------- /src/layout/Source/Layout/Cairo/Prim/Rect.hs: -------------------------------------------------------------------------------- 1 | module Source.Layout.Cairo.Prim.Rect (rect) where 2 | 3 | import Data.Foldable (for_) 4 | 5 | import qualified Graphics.Rendering.Cairo as Cairo 6 | 7 | import Source.Layout.Inj 8 | import Source.Layout.NonNegative 9 | import Source.Layout.Core 10 | 11 | import Source.Layout.Cairo.Prim.Color 12 | import Source.Layout.Cairo.Element 13 | 14 | rect :: 15 | forall g a. 16 | Inj (CairoElement g) a => 17 | g (Maybe (LRTB (NonNegative Double))) -> 18 | g (Maybe Color) -> 19 | Extents -> 20 | a 21 | rect gmthickness gmcolor extents = 22 | inj CairoElement 23 | { cairoElementExtents = extents, 24 | cairoElementBaseline = NoBaseline, 25 | cairoElementRender = render } 26 | where 27 | render :: Offset -> CairoRender g 28 | render (Offset x y) = CairoRender $ \getG -> do 29 | let Extents w h = extents 30 | for_ (getG gmcolor) $ \color -> do 31 | setSourceColor color 32 | for_ (getG gmthickness) $ \thck -> do 33 | Cairo.setFillRule Cairo.FillRuleEvenOdd 34 | Cairo.rectangle 35 | (fromIntegral x + getNonNegative (left thck)) 36 | (fromIntegral y + getNonNegative (top thck)) 37 | (fromIntegral w - getNonNegative (left thck + right thck)) 38 | (fromIntegral h - getNonNegative (top thck + bottom thck)) 39 | Cairo.rectangle 40 | (fromIntegral x) 41 | (fromIntegral y) 42 | (fromIntegral w) 43 | (fromIntegral h) 44 | Cairo.fill 45 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "inputs": { 5 | "systems": "systems" 6 | }, 7 | "locked": { 8 | "lastModified": 1731533236, 9 | "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", 10 | "owner": "numtide", 11 | "repo": "flake-utils", 12 | "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", 13 | "type": "github" 14 | }, 15 | "original": { 16 | "owner": "numtide", 17 | "repo": "flake-utils", 18 | "type": "github" 19 | } 20 | }, 21 | "nixpkgs": { 22 | "locked": { 23 | "lastModified": 1743568003, 24 | "narHash": "sha256-ZID5T65E8ruHqWRcdvZLsczWDOAWIE7om+vQOREwiX0=", 25 | "owner": "NixOS", 26 | "repo": "nixpkgs", 27 | "rev": "b7ba7f9f45c5cd0d8625e9e217c28f8eb6a19a76", 28 | "type": "github" 29 | }, 30 | "original": { 31 | "owner": "NixOS", 32 | "ref": "nixpkgs-unstable", 33 | "repo": "nixpkgs", 34 | "type": "github" 35 | } 36 | }, 37 | "root": { 38 | "inputs": { 39 | "flake-utils": "flake-utils", 40 | "nixpkgs": "nixpkgs" 41 | } 42 | }, 43 | "systems": { 44 | "locked": { 45 | "lastModified": 1681028828, 46 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 47 | "owner": "nix-systems", 48 | "repo": "default", 49 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 50 | "type": "github" 51 | }, 52 | "original": { 53 | "owner": "nix-systems", 54 | "repo": "default", 55 | "type": "github" 56 | } 57 | } 58 | }, 59 | "root": "root", 60 | "version": 7 61 | } 62 | -------------------------------------------------------------------------------- /src/bin/SdamToSvg.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Graphics.Rendering.Cairo 4 | import Sdam.Parser (pValue, parse) 5 | import Source.Layout.Core 6 | import Source.Language.Haskell 7 | import Source.Language.Morte 8 | import Source.NewGen 9 | import System.Environment (getArgs) 10 | import System.Exit (die) 11 | import System.FilePath 12 | import Text.Megaparsec as Megaparsec (errorBundlePretty) 13 | 14 | main :: IO () 15 | main = do 16 | (parsedValue, lang, outputFilepath) <- getArgs >>= \case 17 | ['-' : '-' : lang, filepath] -> do 18 | content <- readFile filepath 19 | case parse pValue filepath content of 20 | Left e -> die (Megaparsec.errorBundlePretty e) 21 | Right a -> return (a, lang, replaceExtension filepath "svg") 22 | _ -> die "Usage: sdam-to-svg --haskell FILE.sd" 23 | plugin <- 24 | case lang of 25 | "haskell" -> return haskellPlugin 26 | "morte" -> return mortePlugin 27 | _ -> die "Unsupported language." 28 | let lctx :: LayoutCtx 29 | lctx = 30 | LayoutCtx 31 | { _lctxPath = mempty @PathBuilder, 32 | _lctxValidationResult = mempty, 33 | _lctxViewport = Extents 0 0, 34 | _lctxPrecBordersAlways = False, 35 | _lctxPrecInfo = pluginPrecInfo plugin, 36 | _lctxShapeNames = pluginShapeNames plugin, 37 | _lctxPlaceholder = Nothing, 38 | _lctxPrecPredicate = precAllowAll, 39 | _lctxWritingDirection = WritingDirectionLTR 40 | } 41 | exprCollage :: Collage () El 42 | exprCollage = layoutNodeStandalone lctx (fromParsedValue parsedValue) 43 | exprExtents = extentsOf exprCollage 44 | dim f = fromIntegral (f exprExtents) 45 | withSVGSurface outputFilepath (dim extentsW) (dim extentsH) $ \surface -> 46 | renderWith surface $ do 47 | cairoRender 48 | (getNoAnn $ foldCairoCollage offsetZero exprCollage) 49 | ($ defaultDrawCtx) 50 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "foundry - a structure for Morte"; 3 | 4 | inputs = { 5 | nixpkgs.url = "github:NixOS/nixpkgs/nixpkgs-unstable"; 6 | flake-utils.url = "github:numtide/flake-utils"; 7 | }; 8 | 9 | outputs = 10 | { self, nixpkgs, flake-utils }: 11 | flake-utils.lib.eachDefaultSystem (system: 12 | let 13 | ghc = "ghc96"; 14 | pkgs = nixpkgs.legacyPackages.${system}; 15 | morte-git = 16 | pkgs.fetchFromGitHub { 17 | owner = "Gabriella439"; 18 | repo = "Haskell-Morte-Library"; 19 | rev = "b7ebbcbea21e3894b889ebd882856ffcdb154160"; 20 | hash = "sha256-jO4EpCA+Xm7+oo0Xa8TIN+TX/bAjvQIcVYfQfbtAC5k="; 21 | }; 22 | haskellPackages = 23 | pkgs.haskell.packages.${ghc}.extend(hself: hsuper: { 24 | foundry = hself.callCabal2nix "foundry" "${self}/src/" {}; 25 | gi-gdk = pkgs.haskell.lib.dontCheck (hself.callHackage "gi-gdk" "4.0.9" {}); 26 | gi-gsk = pkgs.haskell.lib.dontCheck (hself.callHackage "gi-gsk" "4.0.8" {}); 27 | gi-gtk = pkgs.haskell.lib.dontCheck (hself.callHackage "gi-gtk" "4.0.11" {}); 28 | morte = pkgs.haskell.lib.doJailbreak (hself.callCabal2nix "morte" "${morte-git}" {}); 29 | lrucaching = pkgs.haskell.lib.doJailbreak (hself.callHackage "lrucaching" "0.3.4" {}); 30 | }); 31 | in 32 | { 33 | packages = { 34 | foundry = haskellPackages.foundry; 35 | default = self.packages.${system}.foundry; 36 | }; 37 | 38 | devShells.default = pkgs.mkShell { 39 | buildInputs = [ 40 | (haskellPackages.ghcWithPackages(p: 41 | p.foundry.getCabalDeps.libraryHaskellDepends ++ 42 | p.foundry.getCabalDeps.executableHaskellDepends 43 | )) 44 | haskellPackages.foundry.getCabalDeps.executableToolDepends 45 | haskellPackages.hie-bios 46 | haskellPackages.haskell-language-server 47 | haskellPackages.cabal-install 48 | haskellPackages.fast-tags 49 | haskellPackages.ormolu 50 | ]; 51 | }; 52 | }); 53 | } 54 | -------------------------------------------------------------------------------- /src/plugin/Source/Plugin/Precedence.hs: -------------------------------------------------------------------------------- 1 | module Source.Plugin.Precedence 2 | ( PrecBorder (PrecBorder), 3 | PrecUnenclosed (PrecUnenclosed), 4 | addUnenclosed, 5 | guardUnenclosed, 6 | PrecPredicate (PrecPredicate, appPrecPredicate), 7 | precAllow, 8 | precAllowAll, 9 | noPrec, 10 | ) 11 | where 12 | 13 | import Data.HashSet (HashSet) 14 | import qualified Data.HashSet as HashSet 15 | import Data.Hashable (Hashable) 16 | import Sdam.Core 17 | 18 | -- | Is a precedence border needed? 19 | newtype PrecBorder = PrecBorder Bool 20 | 21 | instance Semigroup PrecBorder where 22 | PrecBorder a <> PrecBorder b = PrecBorder (a || b) 23 | 24 | instance Monoid PrecBorder where 25 | mempty = PrecBorder False 26 | 27 | -- | Layouts not enclosed by a precedence border. 28 | newtype PrecUnenclosed = PrecUnenclosed (HashSet SynShape) 29 | 30 | instance Semigroup PrecUnenclosed where 31 | PrecUnenclosed a <> PrecUnenclosed b = 32 | PrecUnenclosed (HashSet.union a b) 33 | 34 | instance Monoid PrecUnenclosed where 35 | mempty = PrecUnenclosed HashSet.empty 36 | 37 | addUnenclosed :: SynShape -> PrecUnenclosed -> PrecUnenclosed 38 | addUnenclosed shape (PrecUnenclosed s) = 39 | PrecUnenclosed (HashSet.insert shape s) 40 | 41 | guardUnenclosed :: PrecBorder -> PrecUnenclosed -> PrecUnenclosed 42 | guardUnenclosed (PrecBorder True) = const mempty 43 | guardUnenclosed (PrecBorder False) = id 44 | 45 | newtype PrecPredicate 46 | = PrecPredicate {appPrecPredicate :: PrecUnenclosed -> PrecBorder} 47 | 48 | precAllow :: HashSet SynShape -> PrecPredicate 49 | precAllow allowed = 50 | PrecPredicate $ \(PrecUnenclosed unenclosed) -> 51 | PrecBorder $ 52 | -- Need a border unless all of unenclosed layouts are allowed. 53 | not (unenclosed `hashSet_isSubsetOf` allowed) 54 | 55 | precAllowAll :: PrecPredicate 56 | precAllowAll = PrecPredicate (const (PrecBorder False)) 57 | 58 | hashSet_isSubsetOf :: (Eq a, Hashable a) => HashSet a -> HashSet a -> Bool 59 | hashSet_isSubsetOf sub sup = 60 | all (\k -> HashSet.member k sup) sub 61 | 62 | noPrec :: PrecPredicate 63 | noPrec = PrecPredicate (const (PrecBorder True)) 64 | -------------------------------------------------------------------------------- /src/lang/morte/Source/Language/Morte.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | 3 | module Source.Language.Morte where 4 | 5 | import Data.HashMap.Strict (HashMap) 6 | import Data.Primitive.Array (Array) 7 | import Sdam.Core 8 | import Source.Plugin 9 | 10 | mortePlugin :: Plugin 11 | mortePlugin = 12 | Plugin 13 | { pluginSchema = morteSchema, 14 | pluginPrecInfo = mortePrecInfo, 15 | pluginShapeNames = morteShapeNames 16 | } 17 | 18 | morteShapeNames :: HashMap SynShape ShapeName 19 | morteShapeNames = 20 | [ "__" ==> ShapeName "function application" ["function", "argument"], 21 | "λ_:_/_" ==> ShapeName "lambda function" ["variable", "type", "body"], 22 | "Π_:_/_" ==> ShapeName "pi-type" ["variable", "type", "body"], 23 | "_@_" ==> ShapeName "indexed variable" ["variable", "index"] 24 | ] 25 | 26 | mortePrecInfo :: HashMap SynShape (Array PrecPredicate) 27 | mortePrecInfo = 28 | [ "__" 29 | ==> [ precAllow (precAtoms <> ["__"]), 30 | precAllow precAtoms 31 | ], 32 | "λ_:_/_" ==> [noPrec, precAllowAll, precAllowAll], 33 | "Π_:_/_" ==> [noPrec, precAllowAll, precAllowAll] 34 | ] 35 | where 36 | precAtoms = ["★", "□"] 37 | 38 | morteSchema :: Schema 39 | morteSchema = 40 | Schema 41 | { schemaShapes = 42 | [ "_@_", 43 | "λ_:_/_", 44 | "Π_:_/_", 45 | "__", 46 | "★", 47 | "□" 48 | ], 49 | schemaRoot = tExpr, 50 | schemaSeqGuard = '|' 51 | } 52 | where 53 | tNat = mempty -- strings only 54 | tVar = mempty -- strings only 55 | tIVar = mkTyUnion "_@_" [tVar, tNat] 56 | tLam = mkTyUnion "λ_:_/_" [tVar, tExpr, tExpr] 57 | tPi = mkTyUnion "Π_:_/_" [tVar, tExpr, tExpr] 58 | tApp = mkTyUnion "__" [tExpr, tExpr] 59 | tStar = mkTyUnion "★" [] 60 | tBox = mkTyUnion "□" [] 61 | tExpr = 62 | mconcat 63 | [ tLam, 64 | tPi, 65 | tApp, 66 | tStar, 67 | tBox, 68 | tVar, 69 | tIVar 70 | ] 71 | 72 | -------------------------------------------------------------------------------- 73 | ---- Helpers 74 | -------------------------------------------------------------------------------- 75 | 76 | (==>) :: a -> b -> (a, b) 77 | (==>) = (,) 78 | 79 | infix 0 ==> 80 | -------------------------------------------------------------------------------- /src/bin/MorteToSdam.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Sequence as Seq 4 | import Data.String (fromString) 5 | import qualified Data.Text.Lazy as Text.Lazy 6 | import Data.Void 7 | import qualified Morte.Core as M 8 | import qualified Morte.Import as M.I 9 | import qualified Morte.Parser as M.P 10 | import Sdam.Core 11 | import Sdam.Printer 12 | import System.Environment (getArgs) 13 | import System.Exit (die) 14 | 15 | main :: IO () 16 | main = do 17 | et <- getArgs >>= \case 18 | [et] -> return et 19 | _ -> die "Usage: morte-to-sdam EXPR" 20 | expr <- 21 | case M.P.exprFromText (fromString et) of 22 | Left err -> die (show err) 23 | Right e -> M.I.load Nothing e 24 | putStrLn $ render (rValue (convertExpr expr)) 25 | 26 | convertExpr :: M.Expr Void -> RenderValue 27 | convertExpr = \case 28 | M.Const c -> convertConst c 29 | M.Var v -> convertVar v 30 | M.Lam x _A b -> convertLam x _A b 31 | M.Pi x _A _B -> convertPi x _A _B 32 | M.App f a -> convertApp f a 33 | M.Embed e -> absurd e 34 | 35 | convertConst :: M.Const -> RenderValue 36 | convertConst = \case 37 | M.Star -> mkRecValue "★" [] 38 | M.Box -> mkRecValue "□" [] 39 | 40 | convertStr :: Text.Lazy.Text -> SynShape 41 | convertStr = Syn . Seq.fromList . map TokenChar . Text.Lazy.unpack 42 | 43 | convertVar :: M.Var -> RenderValue 44 | convertVar = \case 45 | M.V t 0 -> mkRecValue (convertStr t) [] 46 | M.V t n -> 47 | mkRecValue 48 | "_@_" 49 | [ mkRecValue (convertStr t) [], 50 | mkRecValue (fromString (show n)) [] 51 | ] 52 | 53 | convertLam :: Text.Lazy.Text -> M.Expr Void -> M.Expr Void -> RenderValue 54 | convertLam x _A b = 55 | mkRecValue 56 | "λ_:_/_" 57 | [ mkRecValue (convertStr x) [], 58 | convertExpr _A, 59 | convertExpr b 60 | ] 61 | 62 | convertPi :: Text.Lazy.Text -> M.Expr Void -> M.Expr Void -> RenderValue 63 | convertPi x _A _B = 64 | mkRecValue 65 | "Π_:_/_" 66 | [ mkRecValue (convertStr x) [], 67 | convertExpr _A, 68 | convertExpr _B 69 | ] 70 | 71 | convertApp :: M.Expr Void -> M.Expr Void -> RenderValue 72 | convertApp f a = 73 | mkRecValue 74 | "__" 75 | [ convertExpr f, 76 | convertExpr a 77 | ] 78 | 79 | mkRecValue :: SynShape -> [RenderValue] -> RenderValue 80 | mkRecValue shape fields = RenderValue (synReconstruct shape fields) 81 | -------------------------------------------------------------------------------- /src/sdam/Sdam/Parser.hs: -------------------------------------------------------------------------------- 1 | module Sdam.Parser 2 | ( 3 | -- Value 4 | pValue, 5 | ParsedValue(..), 6 | 7 | -- Path 8 | pPath, 9 | 10 | -- Running 11 | parse 12 | ) where 13 | 14 | import Control.Monad 15 | import Data.Void 16 | 17 | import Text.Megaparsec 18 | import Text.Megaparsec.Char 19 | import qualified Text.Megaparsec.Char.Lexer as L 20 | 21 | import Sdam.Core 22 | 23 | type Parser e = Parsec e String 24 | 25 | pWhitespace :: Ord e => Parser e () 26 | pWhitespace = L.space space1 pLineComment pBlockComment 27 | where 28 | pLineComment = L.skipLineComment "//" 29 | pBlockComment = L.skipBlockCommentNested "/*" "*/" 30 | 31 | pLexeme :: Ord e => Parser e a -> Parser e a 32 | pLexeme = L.lexeme pWhitespace 33 | 34 | pSymbol :: Ord e => String -> Parser e () 35 | pSymbol s = void (L.symbol pWhitespace s) 36 | 37 | pSynShape :: Ord e => Parser e SynShape 38 | pSynShape = parseSynShape <$> some pSynShapeChar 39 | 40 | pSynShapeChar :: Ord e => Parser e Char 41 | pSynShapeChar = char '\\' *> pEscaped <|> satisfy (not . needsEscape) 42 | where 43 | pEscaped = anySingle >>= withEscaped 44 | withEscaped 'n' = return '\n' 45 | withEscaped c 46 | | needsEscape c = return c 47 | | otherwise = fail ("Bad escape: " ++ show c) 48 | needsEscape c = 49 | c `elem` ("\\\n " :: [Char]) 50 | 51 | -------------------------------------------------------------------------------- 52 | -- Value 53 | -------------------------------------------------------------------------------- 54 | 55 | type ValueParseErr = Void 56 | 57 | newtype ParsedValue = ParsedValue (Syn ParsedValue) 58 | deriving newtype Show 59 | 60 | pValue :: Parser ValueParseErr ParsedValue 61 | pValue = do 62 | shape <- pLexeme pSynShape 63 | fields <- count (length shape) pValue 64 | return (ParsedValue (synReconstruct shape fields)) 65 | 66 | -------------------------------------------------------------------------------- 67 | -- Value 68 | -------------------------------------------------------------------------------- 69 | 70 | type PathParseErr = Void 71 | 72 | pPath :: Parser PathParseErr Path 73 | pPath = Path <$> sepBy1 pPathSegment (pSymbol "/") 74 | 75 | pPathSegment :: Parser PathParseErr PathSegment 76 | pPathSegment = 77 | pLexeme $ do 78 | shape <- pLexeme pSynShape 79 | i <- between (pSymbol "[") (pSymbol "]") L.decimal 80 | return (PathSegment shape (intToIndex i)) 81 | -------------------------------------------------------------------------------- /src/sdam/Sdam/Core.hs: -------------------------------------------------------------------------------- 1 | module Sdam.Core 2 | ( 3 | -- * Syn 4 | module Sdam.Syn, 5 | 6 | -- * Paths 7 | Path(..), 8 | emptyPath, 9 | consPath, 10 | unconsPath, 11 | PathSegment(..), 12 | Index, 13 | intToIndex, 14 | indexToInt, 15 | PathBuilder(..), 16 | mkPathBuilder, 17 | buildPath, 18 | PathTrie(..), 19 | pathTrieLookup 20 | ) where 21 | 22 | import Data.Hashable (Hashable) 23 | import Data.HashMap.Strict as HashMap 24 | import Control.Exception (ArithException(Underflow), throw) 25 | import GHC.Generics (Generic) 26 | 27 | import Sdam.Syn 28 | 29 | -------------------------------------------------------------------------------- 30 | -- Paths 31 | -------------------------------------------------------------------------------- 32 | 33 | newtype Path = Path [PathSegment] 34 | deriving newtype (Eq, Show) 35 | 36 | emptyPath :: Path 37 | emptyPath = Path [] 38 | 39 | consPath :: PathSegment -> Path -> Path 40 | consPath ps (Path p) = Path (ps:p) 41 | 42 | unconsPath :: Path -> Maybe (PathSegment, Path) 43 | unconsPath (Path p) = 44 | case p of 45 | [] -> Nothing 46 | ps : p' -> Just (ps, Path p') 47 | 48 | {- 49 | 50 | Note that 'PathSegment' is qualified by a 'SynShape': 51 | 52 | * This guarantees that there is no clash between fields with the same name 53 | across different types (that is, each type has its own namespace for fields). 54 | 55 | * This safeguards against duck typing. We wouldn't want code that abstracts over 56 | values by what fields /names/ they have: abstraction should be over meaning, 57 | not over strings. 58 | 59 | -} 60 | data PathSegment = PathSegment SynShape Index 61 | deriving stock (Eq, Show, Generic) 62 | 63 | instance Hashable PathSegment 64 | 65 | -- Invariant: non-negative. 66 | newtype Index = Index Int 67 | deriving newtype (Eq, Show, Hashable) 68 | 69 | intToIndex :: Int -> Index 70 | intToIndex i = 71 | if i < 0 72 | then throw Underflow 73 | else Index i 74 | 75 | indexToInt :: Index -> Int 76 | indexToInt (Index i) = i 77 | 78 | newtype PathBuilder = PathBuilder (Path -> Path) 79 | 80 | instance Semigroup PathBuilder where 81 | PathBuilder f <> PathBuilder g = PathBuilder (f . g) 82 | 83 | instance Monoid PathBuilder where 84 | mempty = PathBuilder id 85 | 86 | mkPathBuilder :: PathSegment -> PathBuilder 87 | mkPathBuilder ps = PathBuilder (consPath ps) 88 | 89 | buildPath :: PathBuilder -> Path 90 | buildPath (PathBuilder pb) = pb emptyPath 91 | 92 | data PathTrie a = 93 | PathTrie 94 | { pathTrieRoot :: a, 95 | pathTrieChildren :: HashMap PathSegment (PathTrie a) 96 | } 97 | 98 | instance Semigroup a => Semigroup (PathTrie a) where 99 | PathTrie r1 c1 <> PathTrie r2 c2 = 100 | PathTrie (r1 <> r2) (HashMap.unionWith (<>) c1 c2) 101 | 102 | instance Monoid a => Monoid (PathTrie a) where 103 | mempty = PathTrie mempty HashMap.empty 104 | 105 | pathTrieLookup :: Monoid a => PathSegment -> PathTrie a -> PathTrie a 106 | pathTrieLookup pathSegment pathTrie = 107 | HashMap.lookupDefault mempty pathSegment (pathTrieChildren pathTrie) 108 | -------------------------------------------------------------------------------- /src/layout/Source/Layout/Inj.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | 3 | An injection is a function that never maps distinct elements of the domain to 4 | the same element of the codomain. For example, @(\\x -> x + 1)@ is an injection, 5 | but @(\\x -> min x 0)@ is not. 6 | 7 | Injections can be used to construct nested structures from singleton elements. 8 | 9 | -} 10 | 11 | module Source.Layout.Inj (Inj(..), Inj1, nothing) where 12 | 13 | import Data.Void 14 | import Numeric.Natural 15 | import Data.Functor.Identity 16 | 17 | -- | Inject @p@ into @a@. 18 | -- 19 | -- By convention, the instances of @Inj@ never match on @p@ and always match on 20 | -- @a@. This guarantees that the users will not encounter overlapping instances. 21 | class Inj p a where 22 | -- | Inject @p@ into @a@. 23 | inj :: p -> a 24 | 25 | default inj :: (p ~ a) => p -> a 26 | inj = \x -> x 27 | 28 | -- | Throws 'Underflow'. 29 | instance Integral p => Inj p Natural where 30 | inj = fromIntegral 31 | 32 | -- | Injective only if the number is representable as 'Double'. 33 | instance Real p => Inj p Double where 34 | inj = realToFrac 35 | 36 | data Decision_Wrap 37 | 38 | data Decision_Map 39 | 40 | type family DecideIdentity p where 41 | DecideIdentity (Identity p) = Decision_Map 42 | DecideIdentity p = Decision_Wrap 43 | 44 | class d ~ DecideIdentity p => InjIdentity d p a where 45 | injIdentity :: p -> Identity a 46 | 47 | instance InjIdentity (DecideIdentity p) p a => Inj p (Identity a) where 48 | inj = injIdentity 49 | 50 | instance 51 | (DecideIdentity p ~ Decision_Wrap, Inj p a) => 52 | InjIdentity Decision_Wrap p a 53 | where 54 | injIdentity = pure . inj 55 | 56 | instance 57 | (DecideIdentity p ~ Decision_Map, p ~ Identity p', Inj p' a) => 58 | InjIdentity Decision_Map p a 59 | where 60 | injIdentity = fmap inj 61 | 62 | type family DecideMaybe p where 63 | DecideMaybe (Maybe p) = Decision_Map 64 | DecideMaybe p = Decision_Wrap 65 | 66 | class d ~ DecideMaybe p => InjMaybe d p a where 67 | injMaybe :: p -> Maybe a 68 | 69 | instance InjMaybe (DecideMaybe p) p a => Inj p (Maybe a) where 70 | inj = injMaybe 71 | 72 | instance 73 | (DecideMaybe p ~ Decision_Wrap, Inj p a) => 74 | InjMaybe Decision_Wrap p a 75 | where 76 | injMaybe = pure . inj 77 | 78 | instance 79 | (DecideMaybe p ~ Decision_Map, p ~ Maybe p', Inj p' a) => 80 | InjMaybe Decision_Map p a 81 | where 82 | injMaybe = fmap inj 83 | 84 | type family DecideFn p where 85 | DecideFn (r -> p) = Decision_Map 86 | DecideFn p = Decision_Wrap 87 | 88 | class d ~ DecideFn p => InjFn d p r a where 89 | injFn :: p -> r -> a 90 | 91 | instance InjFn (DecideFn p) p r a => Inj p (r -> a) where 92 | inj = injFn 93 | 94 | instance 95 | (DecideFn p ~ Decision_Wrap, Inj p a) => 96 | InjFn Decision_Wrap p s a 97 | where 98 | injFn = pure . inj 99 | 100 | instance 101 | (DecideFn p ~ Decision_Map, p ~ (r -> p'), Inj p' a) => 102 | InjFn Decision_Map p r a 103 | where 104 | injFn = fmap inj 105 | 106 | nothing :: Inj (Maybe Void) a => a 107 | nothing = inj (Nothing @Void) 108 | 109 | instance {-# OVERLAPPING #-} Inj Void Natural where 110 | inj = absurd 111 | 112 | class Inj t (f t) => Inj1 f t 113 | 114 | instance Inj t (f t) => Inj1 f t 115 | -------------------------------------------------------------------------------- /src/sdam/Sdam/Syn.hs: -------------------------------------------------------------------------------- 1 | module Sdam.Syn 2 | ( Syn (..), 3 | Token(..), 4 | SynShape, 5 | synShape, 6 | synFields, 7 | SynReconstructException(..), 8 | synReconstruct, 9 | synTryReconstruct, 10 | parseSynShape, 11 | flattenSynShape, 12 | ) 13 | where 14 | 15 | import Data.Hashable as Hashable 16 | import Data.String 17 | import Data.Sequence as Seq 18 | import Data.Foldable as Foldable 19 | import Control.Monad.Trans.State 20 | import GHC.Generics (Generic) 21 | import Control.Exception 22 | 23 | {- | 24 | 25 | Syntactic construct with slots. 26 | 27 | 'Syn' is parametrized by the type of its fields. In the trivial case, we can 28 | take the fixpoint of 'Syn' to have nodes that are made of nodes: 29 | 30 | newtype AST = AST (Syn AST) 31 | 32 | However, we may also use this for extension: 33 | 34 | data Editable = 35 | Node UUID (Syn Editable) 36 | | Hole 37 | 38 | -} 39 | 40 | newtype Syn a = Syn { synTokens :: Seq (Token a) } 41 | deriving stock (Eq, Ord, Show, Generic) 42 | deriving stock (Foldable, Functor, Traversable) 43 | 44 | instance Hashable a => Hashable (Syn a) where 45 | hashWithSalt salt = hashWithSalt salt . Foldable.toList . synTokens 46 | 47 | type SynShape = Syn () 48 | 49 | synShape :: Syn a -> SynShape 50 | synShape = fmap (const ()) 51 | 52 | synFields :: Syn a -> [a] 53 | synFields = toList 54 | 55 | data SynReconstructException 56 | = SynReconstructNotEnoughFields 57 | | SynReconstructTooManyFields 58 | deriving Show 59 | 60 | instance Exception SynReconstructException 61 | 62 | synReconstruct :: SynShape -> [a] -> Syn a 63 | synReconstruct shape fields = either throw id (synTryReconstruct shape fields) 64 | 65 | synTryReconstruct :: SynShape -> [a] -> Either SynReconstructException (Syn a) 66 | synTryReconstruct shape fields = do 67 | let 68 | uncons (x : xs) = Right (x, xs) 69 | uncons [] = Left SynReconstructNotEnoughFields 70 | (r, rest) <- runStateT (traverse (\() -> StateT uncons) shape) fields 71 | case rest of 72 | [] -> Right r 73 | _ : _ -> Left SynReconstructTooManyFields 74 | 75 | flattenSynShape :: SynShape -> String 76 | flattenSynShape = detokenize . Foldable.toList . synTokens 77 | 78 | parseSynShape :: String -> SynShape 79 | parseSynShape = Syn . Seq.fromList . tokenize 80 | 81 | instance s ~ () => IsString (Syn s) where 82 | fromString = parseSynShape 83 | 84 | data Token a 85 | = TokenChar Char 86 | | TokenNode a 87 | deriving stock (Eq, Ord, Show, Generic) 88 | deriving stock (Foldable, Functor, Traversable) 89 | 90 | instance Hashable a => Hashable (Token a) 91 | 92 | -- tokenize . detokenize = id 93 | -- detokenize . tokenize = id 94 | 95 | tokenize :: String -> [Token ()] 96 | tokenize [] = [] 97 | tokenize ('_' : cs) = TokenNode () : tokenize cs 98 | tokenize ('\\' : c : cs) = 99 | if needsEscape c 100 | then TokenChar c : tokenize cs 101 | else TokenChar '\\' : TokenChar c : tokenize cs 102 | tokenize (c : cs) = TokenChar c : tokenize cs 103 | 104 | detokenize :: [Token ()] -> String 105 | detokenize [] = [] 106 | detokenize (TokenNode () : ts) = '_' : detokenize ts 107 | detokenize (TokenChar c : ts) = 108 | if needsEscape c 109 | then '\\' : c : detokenize ts 110 | else c : detokenize ts 111 | 112 | needsEscape :: Char -> Bool 113 | needsEscape c = 114 | case c of 115 | '\n' -> True 116 | '_' -> True 117 | '\\' -> True 118 | _ -> False 119 | -------------------------------------------------------------------------------- /src/driver/Source.hs: -------------------------------------------------------------------------------- 1 | module Source 2 | ( runSource, 3 | ) 4 | where 5 | 6 | import Control.Lens 7 | import Control.Monad 8 | import Control.Monad.State 9 | import Data.IORef 10 | import Data.Tuple 11 | import qualified Graphics.UI.Gtk as Gtk 12 | import qualified Graphics.Rendering.Cairo as Cairo 13 | import Sdam.Parser (ParsedValue) 14 | import Source.Layout.Core 15 | import Source.Input (InputEvent (..), Modifier (..)) 16 | import qualified Source.NewGen as NG 17 | import Source.Phaser 18 | 19 | runSource :: NG.Plugin -> Maybe ParsedValue -> IO () 20 | runSource plugin mParsedValue = do 21 | let pluginInfo = NG.mkPluginInfo plugin 22 | _ <- Gtk.initGUI 23 | esRef <- newIORef $ 24 | case mParsedValue of 25 | Nothing -> NG.initEditorState 26 | Just a -> 27 | let expr = NG.fromParsedValue a 28 | in NG.initEditorState {NG._esExpr = expr} 29 | window <- createMainWindow pluginInfo esRef 30 | Gtk.widgetShowAll window 31 | Gtk.mainGUI 32 | 33 | createMainWindow :: NG.PluginInfo -> IORef NG.EditorState -> IO Gtk.Window 34 | createMainWindow pluginInfo esRef = do 35 | window <- Gtk.windowNew 36 | drawingArea <- Gtk.drawingAreaNew 37 | Gtk.containerAdd window drawingArea 38 | Gtk.windowSetDefaultSize window 800 500 39 | _ <- Gtk.on window Gtk.objectDestroy Gtk.mainQuit 40 | -- TODO: PointerMotionHintMask; eventRequestMotions 41 | Gtk.widgetAddEvents 42 | drawingArea 43 | [ Gtk.PointerMotionMask, 44 | Gtk.ButtonPressMask 45 | ] 46 | cursorPhaser <- newPhaser 530000 NG.CursorVisible NG.blink $ 47 | \_ -> Gtk.postGUIAsync (Gtk.widgetQueueDraw drawingArea) 48 | stackPhaser <- newPhaser 530000 () id $ 49 | \_ -> Gtk.postGUIAsync $ do 50 | atomicRunStateIORef' esRef $ do 51 | NG.esMode %= NG.quitStackMode 52 | Gtk.widgetQueueDraw drawingArea 53 | let updateCanvas viewport = do 54 | es <- liftIO 55 | $ atomicRunStateIORef' esRef 56 | $ do 57 | modify (NG.redrawUI pluginInfo viewport) 58 | get 59 | cursorBlink <- liftIO $ phaserCurrent cursorPhaser 60 | (es ^. NG.esRenderUI) cursorBlink 61 | handleInputEvent inputEvent = do 62 | es <- readIORef esRef 63 | let mEs' = NG.reactEditorState pluginInfo inputEvent es 64 | case mEs' of 65 | NG.UnknownEvent -> do 66 | print inputEvent 67 | return False 68 | NG.ReactOk es' -> do 69 | atomicWriteIORef esRef es' 70 | Gtk.widgetQueueDraw drawingArea 71 | phaserReset stackPhaser () 72 | return True 73 | void $ Gtk.on drawingArea Gtk.draw $ do 74 | (x1, y1, x2, y2) <- Cairo.clipExtents 75 | let (w, h) = (x2 - x1, y2 - y1) 76 | let viewport = Extents (floor w) (floor h) 77 | updateCanvas viewport 78 | void $ Gtk.on window Gtk.keyPressEvent $ do 79 | modifier <- Gtk.eventModifier 80 | keyVal <- Gtk.eventKeyVal 81 | let event = KeyPress (modifier >>= gtkMod) keyVal 82 | liftIO $ do 83 | phaserReset cursorPhaser NG.CursorVisible 84 | handleInputEvent event 85 | void $ Gtk.on drawingArea Gtk.motionNotifyEvent $ do 86 | (x, y) <- Gtk.eventCoordinates 87 | let (x', y') = (round x, round y) 88 | let event = PointerMotion (fromInteger x') (fromInteger y') 89 | liftIO (handleInputEvent event) 90 | void $ Gtk.on drawingArea Gtk.buttonPressEvent $ do 91 | liftIO (handleInputEvent ButtonPress) 92 | Gtk.windowMaximize window 93 | return window 94 | 95 | gtkMod :: Gtk.Modifier -> [Modifier] 96 | gtkMod = \case 97 | Gtk.Control -> [Control] 98 | Gtk.Shift -> [Shift] 99 | Gtk.Alt -> [Alt] 100 | _ -> [] 101 | 102 | -- | Atomically modifies the contents of an 'IORef' using the provided 'State' 103 | -- action. Forces both the value stored in the 'IORef' as well as the value 104 | -- returned. 105 | atomicRunStateIORef' :: IORef s -> State s a -> IO a 106 | atomicRunStateIORef' ref st = atomicModifyIORef' ref (swap . runState st) 107 | -------------------------------------------------------------------------------- /src/layout/Source/Layout/Combinators.hs: -------------------------------------------------------------------------------- 1 | module Source.Layout.Combinators 2 | ( substrate, 3 | collageMarginBB, 4 | collageAnnotateMargin, 5 | horiz, 6 | horizTop, 7 | horizBottom, 8 | horizCenter, 9 | horizBaseline, 10 | vert, 11 | vertLeft, 12 | vertRight, 13 | vertCenter, 14 | insideBox, 15 | integralDistribExcess 16 | ) where 17 | 18 | import Numeric.Natural 19 | import Data.List.NonEmpty 20 | import Source.Layout.Core 21 | 22 | substrate :: 23 | Semigroup n => 24 | LRTB Natural -> 25 | (Extents -> Collage n a) -> 26 | Collage n a -> 27 | Collage n a 28 | substrate pad mkSub collage = 29 | collageCompose 30 | Offset 31 | { offsetX = toInteger $ left pad, 32 | offsetY = toInteger $ top pad } 33 | (mkSub extents) 34 | collage 35 | where 36 | e = collageExtents collage 37 | extents = Extents 38 | { extentsW = left pad + extentsW e + right pad, 39 | extentsH = top pad + extentsH e + bottom pad } 40 | 41 | -- | Collage margin bounding box. The offset is negative (top-left margin). 42 | collageMarginBB :: Collage n a -> (Offset, Extents) 43 | collageMarginBB collage = (offset, extents) 44 | where 45 | e = collageExtents collage 46 | m = collageMargin collage 47 | extents = Extents 48 | { extentsW = marginLeft m + extentsW e + marginRight m, 49 | extentsH = marginTop m + extentsH e + marginBottom m } 50 | offset = Offset 51 | { offsetX = negate . toInteger $ marginLeft m, 52 | offsetY = negate . toInteger $ marginTop m } 53 | 54 | collageAnnotateMargin :: 55 | Semigroup n => 56 | ((Offset, Extents) -> n) -> 57 | Collage n a -> 58 | Collage n a 59 | collageAnnotateMargin ann collage = 60 | collageAnnotate mkAnn collage 61 | where 62 | mkAnn offset' = ann (offsetAdd offset offset', extents) 63 | (offset, extents) = collageMarginBB collage 64 | 65 | horiz, vert :: 66 | Semigroup n => 67 | (Collage n a -> Integer) -> 68 | Collage n a -> 69 | Collage n a -> 70 | Collage n a 71 | horiz align c1 c2 = 72 | positionedItem $ 73 | collageComposeN (At offset1 c1 :| At offset2 c2 : []) 74 | where 75 | m1 = collageMargin c1 76 | m2 = collageMargin c2 77 | marginX = max (marginRight m1) (marginLeft m2) 78 | offsetX = toInteger (widthOf c1 + marginX) 79 | offset1 = Offset{offsetY=align c1, offsetX=0} 80 | offset2 = Offset{offsetY=align c2, offsetX} 81 | vert align c1 c2 = 82 | positionedItem $ 83 | collageComposeN (At offset1 c1 :| At offset2 c2 : []) 84 | where 85 | m1 = collageMargin c1 86 | m2 = collageMargin c2 87 | marginY = max (marginBottom m1) (marginTop m2) 88 | offsetY = toInteger (heightOf c1 + marginY) 89 | offset1 = Offset{offsetX=align c1, offsetY=0} 90 | offset2 = Offset{offsetX=align c2, offsetY} 91 | 92 | horizTop, horizBottom, horizCenter, horizBaseline :: 93 | Semigroup n => Collage n a -> Collage n a -> Collage n a 94 | horizTop = horiz (const 0) 95 | horizBottom = horiz (negate . toInteger . heightOf) 96 | horizCenter = horiz (negate . toInteger . (`quot` 2) . heightOf) 97 | horizBaseline = horiz (negate . toInteger . collageBaselineDefault) 98 | 99 | collageBaselineDefault :: Collage n a -> Natural 100 | collageBaselineDefault c = 101 | case collageBaseline c of 102 | NoBaseline -> heightOf c 103 | Baseline a -> a 104 | 105 | vertLeft, vertRight, vertCenter :: 106 | Semigroup n => Collage n a -> Collage n a -> Collage n a 107 | vertLeft = vert (const 0) 108 | vertRight = vert (negate . toInteger . widthOf) 109 | vertCenter = vert (negate . toInteger . (`quot` 2) . widthOf) 110 | 111 | insideBox :: (Offset, Extents) -> Offset -> Bool 112 | insideBox (Offset ax ay, Extents w h) (Offset x y) = 113 | inRange (ax, bx) x && 114 | inRange (ay, by) y 115 | where 116 | bx = ax + toInteger w 117 | by = ay + toInteger h 118 | inRange (lower, upper) = 119 | liftA2 (&&) (lower<=) (upper>=) 120 | 121 | integralDistribExcess :: Integral n => n -> n -> (n, n) 122 | integralDistribExcess desired actual = (l, r) 123 | where 124 | excess = 125 | if desired > actual 126 | then desired - actual 127 | else 0 128 | l = excess `quot` 2 129 | r = excess - l 130 | -------------------------------------------------------------------------------- /src/sdam/Sdam/Validator.hs: -------------------------------------------------------------------------------- 1 | module Sdam.Validator 2 | ( -- * Schema 3 | Schema (..), 4 | TyUnion, 5 | mkTyUnion, 6 | 7 | -- * Validation 8 | ValidationError (..), 9 | ValidationResult, 10 | ValidationValue (..), 11 | validate, 12 | ) 13 | where 14 | 15 | import Data.Foldable as Foldable 16 | import Data.HashMap.Strict as HashMap 17 | import Data.HashSet as HashSet 18 | import Data.Hashable (Hashable) 19 | import Data.List as List 20 | import GHC.Generics (Generic) 21 | import Sdam.Core 22 | import Prelude hiding (seq) 23 | 24 | data Schema 25 | = Schema 26 | { schemaShapes :: HashSet SynShape, 27 | schemaRoot :: TyUnion, 28 | schemaSeqGuard :: Char 29 | } 30 | 31 | newtype TyUnion = TyUnion (HashMap SynShape [TyUnion]) 32 | 33 | instance Semigroup TyUnion where 34 | TyUnion u1 <> TyUnion u2 = TyUnion (HashMap.unionWith tyDescUnion u1 u2) 35 | where 36 | tyDescUnion :: [TyUnion] -> [TyUnion] -> [TyUnion] 37 | tyDescUnion = List.zipWith (<>) 38 | 39 | instance Monoid TyUnion where 40 | mempty = TyUnion HashMap.empty 41 | 42 | mkTyUnion :: SynShape -> [TyUnion] -> TyUnion 43 | mkTyUnion shape fields = 44 | let syn = synReconstruct shape fields -- does arity validation 45 | in TyUnion (HashMap.singleton (synShape syn) (synFields syn)) 46 | 47 | isSeq :: Char -> Syn a -> Bool 48 | isSeq seqGuard syn = 49 | case Foldable.toList (synTokens syn) of 50 | (TokenChar c : ts) | c == seqGuard, all isTokenNode ts -> True 51 | _ -> False 52 | where 53 | isTokenNode :: Token a -> Bool 54 | isTokenNode (TokenChar _) = False 55 | isTokenNode (TokenNode _) = True 56 | 57 | data ValidationError 58 | = UnknownShape SynShape 59 | | TypeMismatch SynShape (HashSet SynShape) 60 | deriving (Eq, Show, Generic) 61 | 62 | instance Hashable ValidationError 63 | 64 | type ValidationResult = PathTrie (HashSet ValidationError) 65 | 66 | validationError :: ValidationError -> ValidationResult 67 | validationError e = mempty {pathTrieRoot = HashSet.singleton e} 68 | 69 | data ValidationValue 70 | = ValidationValue (Syn ValidationValue) 71 | | SkipValidation 72 | deriving stock (Show) 73 | 74 | validate :: Schema -> ValidationValue -> ValidationResult 75 | validate schema = vValue schemaRoot 76 | where 77 | Schema {schemaShapes, schemaRoot, schemaSeqGuard} = schema 78 | vValue :: 79 | TyUnion -> 80 | ValidationValue -> 81 | ValidationResult 82 | vValue _ SkipValidation = mempty 83 | vValue tyU (ValidationValue syn) = 84 | let shape = synShape syn 85 | fields = synFields syn 86 | in if isSeq schemaSeqGuard syn 87 | then vSeq shape tyU fields 88 | else vShape shape tyU (\fieldTys -> vRec shape fieldTys fields) 89 | vShape :: 90 | SynShape -> 91 | TyUnion -> 92 | ([TyUnion] -> ValidationResult) -> 93 | ValidationResult 94 | vShape shape (TyUnion u) cont = 95 | case HashSet.member shape schemaShapes of 96 | False -> validationError (UnknownShape shape) 97 | True -> 98 | case HashMap.lookup shape u of 99 | Nothing -> validationError (TypeMismatch shape (HashMap.keysSet u)) 100 | Just fieldTys -> cont fieldTys 101 | vRec :: 102 | SynShape -> 103 | [TyUnion] -> 104 | [ValidationValue] -> 105 | ValidationResult 106 | vRec shape fieldTys fields = 107 | let mkPathSegment i = PathSegment shape (intToIndex i) 108 | vField i ty fld = (mkPathSegment i, vValue ty fld) 109 | pathTrieRoot = HashSet.empty 110 | pathTrieChildren = 111 | HashMap.fromList $ 112 | List.zipWith3 113 | vField 114 | [0 ..] 115 | fieldTys 116 | fields 117 | in PathTrie {pathTrieRoot, pathTrieChildren} 118 | vSeq :: 119 | SynShape -> 120 | TyUnion -> 121 | [ValidationValue] -> 122 | ValidationResult 123 | vSeq shape ty fields = 124 | let mkPathSegment i = PathSegment shape (intToIndex i) 125 | vField i fld = (mkPathSegment i, vValue ty fld) 126 | pathTrieRoot = HashSet.empty 127 | pathTrieChildren = 128 | HashMap.fromList $ 129 | List.zipWith 130 | vField 131 | [0 ..] 132 | fields 133 | in PathTrie {pathTrieRoot, pathTrieChildren} 134 | -------------------------------------------------------------------------------- /src/lang/haskell/Source/Language/Haskell.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | 3 | module Source.Language.Haskell where 4 | 5 | import Data.HashMap.Strict (HashMap) 6 | import Data.Primitive.Array (Array) 7 | import Source.Plugin 8 | 9 | haskellPlugin :: Plugin 10 | haskellPlugin = 11 | Plugin 12 | { pluginSchema = haskellSchema, 13 | pluginPrecInfo = haskellPrecInfo, 14 | pluginShapeNames = haskellShapeNames 15 | } 16 | 17 | haskellShapeNames :: HashMap SynShape ShapeName 18 | haskellShapeNames = 19 | [ "__" ==> ShapeName "function application" ["function", "argument"], 20 | "_→_" ==> ShapeName "function type" ["domain", "codomain"], 21 | "λ_/_" ==> ShapeName "lambda function" ["pattern", "body"], 22 | "module_exports_/_" ==> ShapeName "module header" ["name", "entities", "declarations"], 23 | "_::_" ==> ShapeName "type annotation" ["left-hand side", "right-hand side"], 24 | "_@_" ==> ShapeName "as-pattern" ["alias", "pattern"], 25 | "_=_" ==> ShapeName "binding" ["left-hand side", "right-hand side"], 26 | "data_=_" ==> ShapeName "data declaration" ["header", "alternatives"], 27 | "newtype_=_" ==> ShapeName "newtype declaration" ["header", "alternatives"], 28 | "from_import_" ==> ShapeName "import" ["module", "entities"], 29 | "from_import_qualified" ==> ShapeName "import" ["module", "entities"], 30 | "from_as_import_" ==> ShapeName "import" ["module", "alias", "entities"], 31 | "from_as_import_qualified" ==> ShapeName "import" ["module", "alias", "entities"], 32 | "∗" ==> ShapeName "all" [] 33 | ] 34 | 35 | haskellPrecInfo :: HashMap SynShape (Array PrecPredicate) 36 | haskellPrecInfo = 37 | [ "__" ==> [precAllow ["__"], noPrec], 38 | "λ_/_" ==> [precAllowAll, precAllowAll], 39 | "from_import_" ==> [noPrec, precAllowAll], 40 | "from_import_qualified" ==> [noPrec, precAllowAll], 41 | "from_as_import_" ==> [noPrec, precAllowAll, precAllowAll], 42 | "from_as_import_qualified" ==> [noPrec, precAllowAll, precAllowAll], 43 | "module_exports_/_" ==> [noPrec, precAllowAll, precAllowAll], 44 | "_::_" ==> [noPrec, precAllowAll], 45 | "_=_" ==> [noPrec, precAllowAll], 46 | "data_=_" ==> [noPrec, precAllowAll], 47 | "newtype_=_" ==> [noPrec, precAllowAll] 48 | ] 49 | 50 | haskellSchema :: Schema 51 | haskellSchema = 52 | Schema 53 | { schemaShapes = 54 | [ "__", 55 | "_→_", 56 | "λ_/_", 57 | "module_exports_/_", 58 | "_::_", 59 | "_@_", 60 | "_=_", 61 | "data_=_", 62 | "newtype_=_", 63 | "from_import_", 64 | "from_import_qualified", 65 | "from_as_import_", 66 | "from_as_import_qualified", 67 | "∗" 68 | ], 69 | schemaRoot = tMod, 70 | schemaSeqGuard = '|' 71 | } 72 | where 73 | tVar = mempty -- strings only 74 | tStr = mempty -- strings only 75 | tAll = mkTyUnion "∗" [] 76 | tMod = mkTyUnion "module_exports_/_" [tVar, tAll <> tVar, tDecl] 77 | tDecl = 78 | mconcat 79 | [ mkTyUnion "_::_" [tVar, tType], 80 | mkTyUnion "_=_" [tPat, tExpr], 81 | tData, 82 | tImport 83 | ] 84 | tImport = 85 | mconcat 86 | [ mkTyUnion "from_import_" [tVar, tVar], 87 | mkTyUnion "from_import_qualified" [tVar, tVar], 88 | mkTyUnion "from_as_import_" [tVar, tVar, tVar], 89 | mkTyUnion "from_as_import_qualified" [tVar, tVar, tVar] 90 | ] 91 | tData = 92 | mconcat 93 | [ mkTyUnion "data_=_" [tType, tConDecl], 94 | mkTyUnion "newtype_=_" [tType, tConDecl] 95 | ] 96 | tConDecl = 97 | mconcat 98 | [ tVar, 99 | mkTyUnion "__" [tConDecl, tType] 100 | ] 101 | tExpr = 102 | mconcat 103 | [ tVar, 104 | tStr, 105 | mkTyUnion "__" [tExpr, tExpr], 106 | mkTyUnion "λ_/_" [tPat, tExpr], 107 | mkTyUnion "_::_" [tExpr, tType] 108 | ] 109 | tType = 110 | mconcat 111 | [ tVar, 112 | tStr, 113 | mkTyUnion "__" [tExpr, tExpr], 114 | mkTyUnion "_::_" [tType, tType] 115 | ] 116 | tPat = 117 | mconcat 118 | [ tVar, 119 | tStr, 120 | mkTyUnion "__" [tPat, tPat], 121 | mkTyUnion "_::_" [tPat, tType] 122 | ] 123 | 124 | -------------------------------------------------------------------------------- 125 | ---- Helpers 126 | -------------------------------------------------------------------------------- 127 | 128 | (==>) :: a -> b -> (a, b) 129 | (==>) = (,) 130 | 131 | infix 0 ==> 132 | -------------------------------------------------------------------------------- /src/layout/Source/Layout/NonNegative.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | 3 | Non-negative numbers: 4 | 5 | @ 6 | ghci> import Source.Layout.NonNegative 7 | ghci> 2 + 3 :: NonNegative Double 8 | 5.0 9 | ghci> 2 - 3 :: NonNegative Double 10 | *** Exception: arithmetic underflow 11 | @ 12 | 13 | -} 14 | 15 | module Source.Layout.NonNegative 16 | ( NonNegative(), 17 | getNonNegative, 18 | toNonNegative, 19 | unsafeToNonNegative 20 | ) where 21 | 22 | import Control.Exception 23 | import Data.Coerce (coerce) 24 | import Data.Maybe (mapMaybe) 25 | import Foreign.Storable (Storable) 26 | import Text.Printf (PrintfArg) 27 | import Source.Layout.Inj 28 | 29 | -- | An opaque newtype around a number @n@ that asserts that @n >= 0@. 30 | -- The constructor is not exported to maintain the invariant. 31 | newtype NonNegative a = NonNegative a 32 | deriving newtype (Eq, Ord, Show, Real, Integral, RealFrac, Semigroup, Monoid, Storable, PrintfArg) 33 | 34 | -- | Unwrap the newtype. 35 | getNonNegative :: NonNegative a -> a 36 | getNonNegative (NonNegative a) = a 37 | 38 | -- | Throws 'Underflow'. 39 | instance (Inj p a, Ord a, Num a) => Inj p (NonNegative a) where 40 | inj = unsafeToNonNegative . inj 41 | 42 | -- | Check if a number is non-negative and return 'Nothing' if it is negative. 43 | toNonNegative :: (Ord a, Num a) => a -> Maybe (NonNegative a) 44 | toNonNegative d = 45 | if d >= 0 then Just (NonNegative d) else Nothing 46 | 47 | -- | Check if a number is non-negative and throw 'Underflow' if it is negative. 48 | unsafeToNonNegative :: (Ord a, Num a) => a -> NonNegative a 49 | unsafeToNonNegative d = 50 | if d >= 0 then NonNegative d else throw Underflow 51 | 52 | -- | Throws 'Underflow'. 53 | instance (Ord a, Num a) => Num (NonNegative a) where 54 | (+) = coerce ((+) @a) 55 | NonNegative a - NonNegative b = unsafeToNonNegative (a - b) 56 | (*) = coerce ((*) @a) 57 | negate _ = throw Underflow 58 | abs = id 59 | signum = coerce (signum @a) 60 | fromInteger = unsafeToNonNegative . fromInteger 61 | 62 | -- | Throws 'Underflow'. 63 | instance (Ord a, Fractional a) => Fractional (NonNegative a) where 64 | (/) = coerce ((/) @a) 65 | recip = coerce (recip @a) 66 | fromRational = unsafeToNonNegative . fromRational 67 | 68 | -- | Throws 'Underflow'. 69 | instance (Ord a, Num a, Enum a) => Enum (NonNegative a) where 70 | succ = coerce (succ @a) 71 | pred (NonNegative a) = unsafeToNonNegative (pred a) 72 | toEnum = unsafeToNonNegative . toEnum 73 | fromEnum = coerce (fromEnum @a) 74 | enumFrom = coerce (enumFrom @a) 75 | enumFromThen (NonNegative n) (NonNegative n') 76 | | n' < n = coerce (takeWhile (>=0) (enumFromThen n n')) 77 | | otherwise = coerce (enumFromThen n n') 78 | enumFromTo = coerce (enumFromTo @a) 79 | enumFromThenTo = coerce (enumFromThenTo @a) 80 | 81 | -- | Throws 'Underflow'. 82 | instance (Ord a, Num a, Floating a) => Floating (NonNegative a) where 83 | pi = coerce (pi @a) 84 | exp = coerce (exp @a) 85 | log (NonNegative a) = unsafeToNonNegative (log a) 86 | sqrt = coerce (sqrt @a) 87 | (**) = coerce ((**) @a) 88 | logBase (NonNegative b) (NonNegative a) = unsafeToNonNegative (logBase b a) 89 | sin (NonNegative a) = unsafeToNonNegative (sin a) 90 | cos (NonNegative a) = unsafeToNonNegative (cos a) 91 | tan (NonNegative a) = unsafeToNonNegative (tan a) 92 | asin (NonNegative a) = unsafeToNonNegative (asin a) 93 | acos (NonNegative a) = unsafeToNonNegative (acos a) 94 | atan (NonNegative a) = unsafeToNonNegative (atan a) 95 | sinh (NonNegative a) = unsafeToNonNegative (sinh a) 96 | cosh (NonNegative a) = unsafeToNonNegative (cosh a) 97 | tanh (NonNegative a) = unsafeToNonNegative (tanh a) 98 | asinh (NonNegative a) = unsafeToNonNegative (asinh a) 99 | acosh (NonNegative a) = unsafeToNonNegative (acosh a) 100 | atanh (NonNegative a) = unsafeToNonNegative (atanh a) 101 | 102 | -- | Throws 'Underflow'. 103 | instance (Ord a, Num a, RealFloat a) => RealFloat (NonNegative a) where 104 | floatRadix = coerce (floatRadix @a) 105 | floatDigits = coerce (floatDigits @a) 106 | floatRange = coerce (floatRange @a) 107 | decodeFloat = coerce (decodeFloat @a) 108 | encodeFloat s e = unsafeToNonNegative (encodeFloat s e) 109 | exponent = coerce (exponent @a) 110 | significand = coerce (significand @a) 111 | scaleFloat = coerce (scaleFloat @a) 112 | isNaN = coerce (isNaN @a) 113 | isInfinite = coerce (isInfinite @a) 114 | isDenormalized = coerce (isDenormalized @a) 115 | isNegativeZero = coerce (isNegativeZero @a) 116 | isIEEE = coerce (isIEEE @a) 117 | atan2 (NonNegative y) (NonNegative x) = unsafeToNonNegative (atan2 y x) 118 | 119 | instance (Ord a, Num a, Read a) => Read (NonNegative a) where 120 | readsPrec n s = mapMaybe (_1 toNonNegative) (readsPrec n s) 121 | readList s = mapMaybe (_1 (traverse toNonNegative)) (readList s) 122 | 123 | _1 :: Functor f => (a -> f a') -> (a, b) -> f (a', b) 124 | _1 f (a, b) = (\a' -> (a', b)) <$> f a 125 | -------------------------------------------------------------------------------- /src/layout/Source/Layout/Cairo/Prim/Curve.hs: -------------------------------------------------------------------------------- 1 | module Source.Layout.Cairo.Prim.Curve 2 | ( Curvature(..), 3 | Corner(..), 4 | Direction(..), 5 | directionFrom, 6 | Arrowhead(..), 7 | curve, 8 | arrowhead 9 | ) where 10 | 11 | import Data.Foldable (for_) 12 | 13 | import qualified Graphics.Rendering.Cairo as Cairo 14 | 15 | import Source.Layout.Inj 16 | import Source.Layout.NonNegative 17 | import Source.Layout.Core 18 | 19 | import Source.Layout.Cairo.Prim.Color 20 | import Source.Layout.Cairo.Element 21 | 22 | -- from -1 to 1 23 | newtype Curvature = Curvature Rational 24 | 25 | instance p ~ Curvature => Inj p Curvature 26 | 27 | curvatureCoeff :: Curvature -> Double 28 | curvatureCoeff (Curvature r) = fromRational r 29 | 30 | data Corner = TopLeft | TopRight | BottomLeft | BottomRight 31 | 32 | directionFrom :: Inj Direction a => Corner -> a 33 | directionFrom TopLeft = 34 | inj Direction { directionLeftToRight = True, directionTopToBottom = True } 35 | directionFrom TopRight = 36 | inj Direction { directionLeftToRight = False, directionTopToBottom = True } 37 | directionFrom BottomLeft = 38 | inj Direction { directionLeftToRight = True, directionTopToBottom = False } 39 | directionFrom BottomRight = 40 | inj Direction { directionLeftToRight = False, directionTopToBottom = False } 41 | 42 | data Direction = 43 | Direction 44 | { directionLeftToRight :: Bool, 45 | directionTopToBottom :: Bool 46 | } 47 | 48 | instance p ~ Direction => Inj p Direction 49 | 50 | data Arrowhead g = 51 | Arrowhead 52 | { arrowheadWidth :: g (NonNegative Double), 53 | arrowheadLength :: g (NonNegative Double), 54 | arrowheadDepth :: g (NonNegative Double) 55 | } 56 | 57 | instance p ~ Arrowhead g => Inj p (Arrowhead g) 58 | 59 | arrowhead :: 60 | Inj (Arrowhead g) a => 61 | g (NonNegative Double) -> 62 | g (NonNegative Double) -> 63 | g (NonNegative Double) -> 64 | a 65 | arrowhead width len depth = 66 | inj (Arrowhead width len depth) 67 | 68 | curve :: 69 | forall g a. 70 | Inj (CairoElement g) a => 71 | Maybe Color -> 72 | g Curvature -> 73 | g Color -> 74 | g Direction -> 75 | g (NonNegative Double) -> 76 | Maybe (Arrowhead g) -> 77 | Extents -> 78 | a 79 | curve mdebug gcurvature gcolor gdirection gwidth marrowhead extents = 80 | inj CairoElement 81 | { cairoElementExtents = extents, 82 | cairoElementBaseline = NoBaseline, 83 | cairoElementRender = render } 84 | where 85 | render :: Offset -> CairoRender g 86 | render offset = CairoRender $ \getG -> do 87 | let 88 | o = (fromIntegral $ offsetX offset, fromIntegral $ offsetY offset) 89 | width = getG gwidth 90 | curvature = getG gcurvature 91 | direction = getG gdirection 92 | Extents (fromIntegral -> w) (fromIntegral -> h) = extents 93 | (x1, x2) = if directionLeftToRight direction then (0, w) else (w, 0) 94 | (y1, y2) = if directionTopToBottom direction then (0, h) else (h, 0) 95 | p0 = (x1, y1) 96 | p1 = bendPoint curvature (w/2, y1) (x1, h/2) 97 | p2 = bendPoint curvature (w/2, y2) (x2, h/2) 98 | p3 = (x2, y2) 99 | (kp0, kp1, kp2, kp3) = 100 | ( liftPair (+) o p0, 101 | liftPair (+) o p1, 102 | liftPair (+) o p2, 103 | liftPair (+) o p3 ) 104 | (renderArrowhead, kp2', kp3') = case marrowhead of 105 | Nothing -> (return (), kp2', kp3) 106 | Just (Arrowhead garrWidth garrLen garrDepth) -> 107 | let 108 | arrLen = getNonNegative (getG garrLen) 109 | arrWidthHalf = getNonNegative (getG garrWidth) / 2 110 | arrDepth = getNonNegative (getG garrDepth) 111 | 112 | kp2'' = rot kp2 (0, arrLen) 113 | kp3'' = rot kp3 (0, arrLen) 114 | 115 | (sine, cosine) = angleFromPoints kp2 kp3 116 | rot kp (x, y) = liftPair (+) kp (x', y') 117 | where 118 | x' = negate (x * sine + y * cosine) 119 | y' = x * cosine - y * sine 120 | 121 | rot' cto x y = 122 | let (x', y') = rot kp3 (x, y) 123 | in cto x' y' 124 | 125 | renderArr = do 126 | Cairo.newPath 127 | rot' Cairo.moveTo 0 0 128 | rot' Cairo.lineTo (negate arrWidthHalf) (arrDepth + arrLen) 129 | rot' Cairo.lineTo 0 arrLen 130 | rot' Cairo.lineTo arrWidthHalf (arrDepth + arrLen) 131 | Cairo.closePath 132 | Cairo.fill 133 | in 134 | (renderArr, kp2'', kp3'') 135 | setSourceColor (getG gcolor) 136 | Cairo.moveTo (fst kp0) (snd kp0) 137 | Cairo.curveTo 138 | (fst kp1) (snd kp1) 139 | (fst kp2') (snd kp2') 140 | (fst kp3') (snd kp3') 141 | Cairo.setLineWidth $ getNonNegative width 142 | Cairo.stroke 143 | renderArrowhead 144 | for_ mdebug $ \color -> do 145 | setSourceColor color 146 | for_ [kp0, kp1, kp2', kp3'] $ \(x, y) -> do 147 | Cairo.arc x y (getNonNegative width) 0 (2 * pi) 148 | Cairo.fill 149 | Cairo.moveTo (fst kp0) (snd kp0) 150 | for_ [kp1, kp2', kp3'] $ \(x, y) -> Cairo.lineTo x y 151 | Cairo.setLineWidth (getNonNegative width) 152 | Cairo.stroke 153 | 154 | angleFromPoints :: (Double, Double) -> (Double, Double) -> (Double, Double) 155 | angleFromPoints (a, b) (c, d) = (sine, cosine) 156 | where 157 | x = c - a 158 | y = d - b 159 | r = sqrt (x * x + y * y) 160 | sine = y / r 161 | cosine = x / r 162 | 163 | liftPair :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c) 164 | liftPair fn (a1, a2) (b1, b2) = (fn a1 b1, fn a2 b2) 165 | 166 | bend :: Curvature -> Double -> Double -> Double 167 | bend c a b = c' * (b - a) + a 168 | where 169 | c' = (curvatureCoeff c + 1) / 2 170 | 171 | bendPoint :: Curvature -> (Double, Double) -> (Double, Double) -> (Double, Double) 172 | bendPoint c (ax, ay) (bx, by) = 173 | (bend c ax bx, bend c ay by) 174 | -------------------------------------------------------------------------------- /src/bin/HaskellToSdam.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Foldable (toList) 4 | import qualified Data.Sequence as Seq 5 | import Data.Text (Text) 6 | import qualified Data.Text as Text 7 | 8 | import Sdam.Core 9 | import Sdam.Printer 10 | import System.Environment (getArgs) 11 | import System.Exit (die) 12 | 13 | import GHC.Hs (GhcPs) 14 | import qualified GHC.Hs as GHC 15 | import qualified GHC.Parser as GHC 16 | import qualified GHC.Parser.Lexer as GHC 17 | import qualified GHC.Types.SrcLoc as GHC 18 | import qualified GHC.Types.Name as GHC 19 | import qualified GHC.Types.Name.Reader as GHC 20 | import qualified GHC.Data.StringBuffer as GHC 21 | import qualified GHC.Data.FastString as GHC 22 | import qualified GHC.Data.EnumSet as GHC.EnumSet 23 | import qualified GHC.Utils.Outputable as GHC 24 | import qualified GHC.Utils.Error as GHC 25 | 26 | main :: IO () 27 | main = do 28 | et <- getArgs >>= \case 29 | [et] -> return et 30 | _ -> die "Usage: haskell-to-sdam EXPR" 31 | hs_mod <- 32 | case parseModuleStr et of 33 | Nothing -> die "Parsing failed" 34 | Just e -> return e 35 | putStrLn $ render (rValue (convertModule (GHC.unLoc hs_mod))) 36 | 37 | convertModule :: GHC.HsModule GhcPs -> RenderValue 38 | convertModule GHC.HsModule {GHC.hsmodName, GHC.hsmodExports, GHC.hsmodDecls} = 39 | mkRecValue 40 | "module_exports_/_" 41 | [ case hsmodName of 42 | Nothing -> mkStrValue (Text.pack "Main") 43 | Just name -> convertModuleName (GHC.unLoc name), 44 | case hsmodExports of 45 | Nothing -> mkRecValue "∗" [] 46 | Just ex -> convertExports (GHC.unLoc ex), 47 | mkSeqValue (convertDecl . GHC.unLoc) hsmodDecls 48 | ] 49 | 50 | convertModuleName :: GHC.ModuleName -> RenderValue 51 | convertModuleName modname = mkStrValue (Text.pack (GHC.moduleNameString modname)) 52 | 53 | convertExports :: [GHC.LIE GhcPs] -> RenderValue 54 | convertExports = mkSeqValue (convertIE . GHC.unLoc) 55 | 56 | convertIE :: GHC.IE GhcPs -> RenderValue 57 | convertIE _ = error "TODO: convertIE" 58 | 59 | convertDecl :: GHC.HsDecl GhcPs -> RenderValue 60 | convertDecl (GHC.SigD _ (GHC.TypeSig _ names ty)) = 61 | convertTypeSig 62 | (map GHC.unLoc names) 63 | (GHC.unLoc (GHC.sig_body (GHC.unLoc (GHC.hswc_body ty)))) 64 | convertDecl (GHC.ValD _ GHC.FunBind {GHC.fun_id, GHC.fun_matches}) = 65 | convertFunBind 66 | (GHC.unLoc fun_id) 67 | fun_matches 68 | convertDecl _ = error "TODO: convertDecl" 69 | 70 | convertFunBind :: GHC.IdP GhcPs -> GHC.MatchGroup GhcPs (GHC.LHsExpr GhcPs) -> RenderValue 71 | convertFunBind name GHC.MG {GHC.mg_alts} = 72 | mkSeqValue (convertMatch name . GHC.unLoc) (GHC.unLoc mg_alts) 73 | 74 | convertMatch :: GHC.IdP GhcPs -> GHC.Match GhcPs (GHC.LHsExpr GhcPs) -> RenderValue 75 | convertMatch name GHC.Match {GHC.m_pats, GHC.m_grhss} = 76 | mkRecValue 77 | "_=_" 78 | [ toApps name m_pats, 79 | convertGRHSs m_grhss 80 | ] 81 | where 82 | toApps n ps = 83 | foldl 84 | (\f p -> mkRecValue "__" [f, p]) 85 | (convertName n) 86 | (map (convertPat . GHC.unLoc) ps) 87 | 88 | convertPat :: GHC.Pat GhcPs -> RenderValue 89 | convertPat _ = error "TODO: convertPat" 90 | 91 | convertGRHSs :: GHC.GRHSs GhcPs (GHC.LHsExpr GhcPs) -> RenderValue 92 | convertGRHSs GHC.GRHSs {GHC.grhssGRHSs} = 93 | mkSeqValue (convertGRHS . GHC.unLoc) grhssGRHSs 94 | 95 | convertGRHS :: GHC.GRHS GhcPs (GHC.LHsExpr GhcPs) -> RenderValue 96 | convertGRHS (GHC.GRHS _ [] b) = convertExpr (GHC.unLoc b) 97 | convertGRHS _ = error "TODO: convertGRHS" 98 | 99 | convertTypeSig :: [GHC.IdP GhcPs] -> GHC.HsType GhcPs -> RenderValue 100 | convertTypeSig names ty = 101 | mkRecValue 102 | "_::_" 103 | [ mkSeqValue convertName names, 104 | convertType ty 105 | ] 106 | 107 | convertName :: GHC.IdP GhcPs -> RenderValue 108 | convertName name = 109 | mkStrValue (Text.pack (GHC.occNameString (GHC.rdrNameOcc name))) 110 | 111 | convertType :: GHC.HsType GhcPs -> RenderValue 112 | convertType (GHC.HsTyVar _ _ name) = convertName (GHC.unLoc name) 113 | convertType (GHC.HsAppTy _ t1 t2) = 114 | mkRecValue 115 | "__" 116 | [ convertType (GHC.unLoc t1), 117 | convertType (GHC.unLoc t2) 118 | ] 119 | convertType (GHC.HsTupleTy _ GHC.HsBoxedOrConstraintTuple []) = 120 | mkRecValue "()" [] 121 | convertType _ = error "TODO: convertType" 122 | 123 | convertExpr :: GHC.HsExpr GhcPs -> RenderValue 124 | convertExpr (GHC.HsVar _ name) = convertName (GHC.unLoc name) 125 | convertExpr (GHC.HsApp _ e1 e2) = 126 | mkRecValue 127 | "__" 128 | [ convertExpr (GHC.unLoc e1), 129 | convertExpr (GHC.unLoc e2) 130 | ] 131 | convertExpr (GHC.HsLit _ lit) = 132 | convertLit lit 133 | convertExpr _ = error "TODO: convertExpr" 134 | 135 | convertLit :: GHC.HsLit GhcPs -> RenderValue 136 | convertLit (GHC.HsString _ s) = 137 | mkStrValue (Text.pack ('"' : GHC.unpackFS s)) 138 | convertLit _ = error "TODO: convertLit" 139 | 140 | mkRecValue :: SynShape -> [RenderValue] -> RenderValue 141 | mkRecValue shape fields = RenderValue (synReconstruct shape fields) 142 | 143 | mkStrValue :: Text -> RenderValue 144 | mkStrValue = RenderValue . Syn . Seq.fromList . map TokenChar . Text.unpack 145 | 146 | mkSeqValue :: Foldable f => (a -> RenderValue) -> f a -> RenderValue 147 | mkSeqValue f c = 148 | case toList c of 149 | [x] -> f x 150 | xs -> 151 | RenderValue . Syn . Seq.fromList $ 152 | TokenChar '|' : map (TokenNode . f) xs 153 | 154 | parseModuleStr :: String -> Maybe (GHC.Located (GHC.HsModule GhcPs)) 155 | parseModuleStr = runGhcParser GHC.parseModule 156 | 157 | runGhcParser :: GHC.P a -> String -> Maybe a 158 | runGhcParser p s = 159 | case GHC.unP p initPState of 160 | GHC.PFailed _ -> Nothing 161 | GHC.POk _ a -> Just a 162 | where 163 | initPState :: GHC.PState 164 | initPState = GHC.initParserState opts buffer location 165 | opts :: GHC.ParserOpts 166 | opts = GHC.mkParserOpts GHC.EnumSet.empty (GHC.DiagOpts GHC.EnumSet.empty GHC.EnumSet.empty False False Nothing GHC.defaultSDocContext) [] False False False False 167 | buffer :: GHC.StringBuffer 168 | buffer = GHC.stringToStringBuffer s 169 | location :: GHC.RealSrcLoc 170 | location = GHC.mkRealSrcLoc (GHC.mkFastString "") 1 1 171 | -------------------------------------------------------------------------------- /src/foundry.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: foundry 3 | version: 0.1.0.0 4 | build-type: Simple 5 | 6 | common language 7 | default-language: GHC2021 8 | default-extensions: 9 | BangPatterns 10 | ConstraintKinds 11 | DataKinds 12 | DefaultSignatures 13 | DeriveGeneric 14 | DeriveFunctor 15 | DeriveFoldable 16 | DeriveTraversable 17 | DerivingStrategies 18 | FlexibleContexts 19 | FlexibleInstances 20 | FunctionalDependencies 21 | GADTs 22 | GeneralizedNewtypeDeriving 23 | LambdaCase 24 | MultiWayIf 25 | NegativeLiterals 26 | OverloadedStrings 27 | PatternSynonyms 28 | PolyKinds 29 | RankNTypes 30 | RecordWildCards 31 | RecursiveDo 32 | ScopedTypeVariables 33 | StandaloneDeriving 34 | TemplateHaskell 35 | TupleSections 36 | TypeApplications 37 | TypeFamilies 38 | TypeOperators 39 | UndecidableInstances 40 | ViewPatterns 41 | ghc-options: 42 | -Wall 43 | 44 | 45 | library 46 | import: language 47 | 48 | exposed-modules: Source 49 | Source.Input 50 | Source.Input.KeyCode 51 | Source.Phaser 52 | Source.NewGen 53 | 54 | build-depends: base >=4.7 55 | , containers 56 | , dlist 57 | , unordered-containers 58 | , primitive 59 | , hashable 60 | , lens >=4.11 61 | , transformers >=0.4 62 | , gtk3 >=0.13 63 | , cairo >=0.13 64 | , pango >=0.13 65 | , text >=1.2 66 | , streams >=3.2.1 67 | , semigroups >=0.16 68 | , mtl >= 2.2.1 69 | , bifunctors 70 | , slay-cairo 71 | , sdam 72 | , source-plugin 73 | , num-non-negative 74 | 75 | hs-source-dirs: driver 76 | 77 | ghc-options: -O2 78 | ghc-prof-options: -fprof-auto 79 | -auto-all 80 | -caf-all 81 | 82 | library source-plugin 83 | import: language 84 | exposed-modules: Source.Plugin 85 | Source.Plugin.Precedence 86 | build-depends: base >=4.7, 87 | unordered-containers, text, primitive, 88 | hashable, sdam 89 | hs-source-dirs: plugin 90 | ghc-options: -O2 91 | ghc-prof-options: -fprof-auto 92 | -auto-all 93 | -caf-all 94 | 95 | 96 | library source-language-haskell 97 | import: language 98 | exposed-modules: Source.Language.Haskell 99 | build-depends: base >=4.7, 100 | unordered-containers, text, primitive, 101 | sdam, source-plugin 102 | hs-source-dirs: lang/haskell 103 | ghc-options: -O2 104 | ghc-prof-options: -fprof-auto 105 | -auto-all 106 | -caf-all 107 | 108 | library source-language-morte 109 | import: language 110 | exposed-modules: Source.Language.Morte 111 | build-depends: base >=4.7, 112 | unordered-containers, text, primitive, 113 | sdam, source-plugin 114 | hs-source-dirs: lang/morte 115 | ghc-options: -O2 116 | ghc-prof-options: -fprof-auto 117 | -auto-all 118 | -caf-all 119 | 120 | library sdam 121 | import: language 122 | exposed-modules: 123 | Sdam.Syn 124 | Sdam.Core 125 | Sdam.Parser 126 | Sdam.Printer 127 | Sdam.Validator 128 | build-depends: 129 | base, containers, unordered-containers, hashable, text, transformers, 130 | megaparsec, parser-combinators, pretty 131 | hs-source-dirs: sdam 132 | ghc-options: -Wno-partial-type-signatures 133 | 134 | library slay-cairo 135 | import: language 136 | 137 | exposed-modules: 138 | Source.Layout.Inj 139 | Source.Layout.NonNegative 140 | Source.Layout.Core 141 | Source.Layout.Combinators 142 | Source.Layout.Cairo 143 | Source.Layout.Cairo.Element 144 | Source.Layout.Cairo.Prim 145 | Source.Layout.Cairo.Prim.Color 146 | Source.Layout.Cairo.Prim.Rect 147 | Source.Layout.Cairo.Prim.Text 148 | Source.Layout.Cairo.Prim.Curve 149 | Source.Layout.Cairo.Prim.Circle 150 | 151 | build-depends: 152 | base, 153 | text, 154 | cairo, 155 | pango, 156 | hashable, 157 | lrucaching, 158 | num-non-negative 159 | 160 | hs-source-dirs: 161 | layout 162 | 163 | executable foundry 164 | import: language 165 | 166 | main-is: Foundry.hs 167 | 168 | build-depends: base, unordered-containers, megaparsec, 169 | sdam, source-language-morte, foundry 170 | 171 | hs-source-dirs: bin 172 | 173 | ghc-options: -threaded -O2 174 | ghc-prof-options: -fprof-auto 175 | -rtsopts 176 | -auto-all 177 | -caf-all 178 | 179 | executable hask 180 | import: language 181 | 182 | main-is: Hask.hs 183 | 184 | build-depends: base, unordered-containers, megaparsec, 185 | sdam, source-language-haskell, foundry 186 | 187 | hs-source-dirs: bin 188 | 189 | ghc-options: -threaded -O2 190 | 191 | ghc-prof-options: -fprof-auto 192 | -rtsopts 193 | -auto-all 194 | -caf-all 195 | 196 | executable morte-to-sdam 197 | import: language 198 | 199 | main-is: MorteToSdam.hs 200 | build-depends: base, text, containers, morte, sdam 201 | hs-source-dirs: bin 202 | ghc-options: -threaded -O2 203 | 204 | executable haskell-to-sdam 205 | import: language 206 | 207 | main-is: HaskellToSdam.hs 208 | build-depends: base, text, containers, unordered-containers, containers, 209 | ghc-lib-parser, sdam, source-language-haskell 210 | hs-source-dirs: bin 211 | ghc-options: -threaded -O2 212 | 213 | executable sdam-to-svg 214 | import: language 215 | 216 | main-is: SdamToSvg.hs 217 | build-depends: base, megaparsec, cairo, filepath, 218 | slay-cairo, sdam, foundry, 219 | source-language-haskell, 220 | source-language-morte 221 | hs-source-dirs: bin 222 | ghc-options: -threaded -O2 223 | -------------------------------------------------------------------------------- /src/layout/Source/Layout/Cairo/Prim/Text.hs: -------------------------------------------------------------------------------- 1 | module Source.Layout.Cairo.Prim.Text 2 | ( FontWeight(..), 3 | Font(..), 4 | text, 5 | monoChar 6 | ) where 7 | 8 | import Data.Fixed 9 | import Data.Text 10 | import Data.Hashable 11 | import Numeric.Natural 12 | import Control.Monad 13 | import GHC.Generics (Generic) 14 | import Data.Foldable (for_) 15 | import System.IO (hPutStrLn, stderr) 16 | import System.IO.Unsafe (unsafePerformIO) 17 | import qualified Data.LruCache.IO as LRU 18 | import Data.Text as Text 19 | 20 | import qualified Graphics.Rendering.Cairo as Cairo 21 | import qualified Graphics.Rendering.Pango as Pango 22 | 23 | import Source.Layout.Inj 24 | import Source.Layout.Core 25 | import Source.Layout.Cairo.Element 26 | import Source.Layout.Cairo.Prim.Color 27 | 28 | data FontWeight = 29 | FontWeightBold | FontWeightNormal 30 | deriving (Eq, Ord, Show, Generic) 31 | 32 | instance Hashable FontWeight 33 | 34 | instance p ~ FontWeight => Inj p FontWeight 35 | 36 | data Font = 37 | Font 38 | { fontFamily :: Text, 39 | fontSize :: Centi, 40 | fontWeight :: FontWeight 41 | } deriving (Eq, Ord, Show, Generic) 42 | 43 | instance Hashable Font 44 | 45 | instance p ~ Font => Inj p Font 46 | 47 | text :: 48 | forall g a. 49 | Inj (CairoElement g) a => 50 | Font -> 51 | g Color -> 52 | Text -> 53 | g (Maybe Natural) -> 54 | a 55 | text font gcolor content gcursor = 56 | inj CairoElement 57 | { cairoElementExtents = extents, 58 | cairoElementBaseline = baseline, 59 | cairoElementRender = render } 60 | where 61 | (extents, baseline, pangoLayout) = primTextPango font content 62 | 63 | render :: Offset -> CairoRender g 64 | render (Offset x y) = CairoRender $ \getG -> do 65 | let Extents w h = extents 66 | let color = getG gcolor 67 | -- TODO: take the transformation matrix into account, otherwise the text 68 | -- is scaled after rendering and becomes blurry 69 | surface <- Cairo.withTargetSurface $ \targetSurface -> 70 | Cairo.liftIO $ LRU.cached surfaceCacheHndl (font, color, content) $ do 71 | -- TODO: When we know the background color, prefer "ContentColor" without "Alpha" to get 72 | -- subpixel antialiasing (instead of grayscale). 73 | s <- Cairo.createSimilarSurface targetSurface Cairo.ContentColorAlpha (fromIntegral w) (fromIntegral h) 74 | Cairo.renderWith s $ do 75 | setSourceColor color 76 | Pango.showLayout pangoLayout 77 | return s 78 | Cairo.setSourceSurface surface (fromIntegral x) (fromIntegral y) 79 | Cairo.paint 80 | setSourceColor color 81 | Cairo.moveTo (fromIntegral x) (fromIntegral y) 82 | for_ (getG gcursor) $ \n -> do 83 | Pango.PangoRectangle gx gy _ gh <- 84 | Cairo.liftIO $ Pango.layoutIndexToPos pangoLayout (fromIntegral n) 85 | Cairo.rectangle 86 | (fromIntegral x + gx) 87 | (fromIntegral y + gy) 88 | 1 89 | gh 90 | Cairo.fill 91 | 92 | primFontPango :: Font -> IO Pango.FontDescription 93 | primFontPango font = do 94 | pangoFont <- Pango.fontDescriptionNew 95 | pangoFont `Pango.fontDescriptionSetFamily` Text.unpack (fontFamily font) 96 | pangoFont `Pango.fontDescriptionSetSize` realToFrac (fontSize font) 97 | pangoFont `Pango.fontDescriptionSetWeight` (case fontWeight font of 98 | FontWeightNormal -> Pango.WeightNormal 99 | FontWeightBold -> Pango.WeightBold) 100 | return pangoFont 101 | 102 | layoutCacheHndl :: LRU.LruHandle (Font, Text) (Extents, Baseline, Pango.PangoLayout) 103 | layoutCacheHndl = unsafePerformIO (LRU.newLruHandle 1000) 104 | {-# NOINLINE layoutCacheHndl #-} 105 | 106 | primTextPango :: Font -> Text -> (Extents, Baseline, Pango.PangoLayout) 107 | primTextPango font content = unsafePerformIO (primTextPangoIO font content) 108 | {-# NOINLINE primTextPango #-} 109 | 110 | primTextPangoIO :: Font -> Text -> IO (Extents, Baseline, Pango.PangoLayout) 111 | primTextPangoIO font content = 112 | LRU.cached layoutCacheHndl (font, content) $ do 113 | pangoFont <- primFontPango font 114 | pangoContext <- Pango.cairoCreateContext Nothing 115 | pangoContext `Pango.contextSetFontDescription` pangoFont 116 | -- pangoContext `Pango.contextSetMatrix` matrix 117 | pangoLayout <- Pango.layoutEmpty pangoContext 118 | pangoLayout `Pango.layoutSetText` Text.unpack content 119 | pangoLayout `Pango.layoutSetFontDescription` Just pangoFont 120 | (_, Pango.PangoRectangle _ _ w h) <- 121 | Pango.layoutGetExtents pangoLayout 122 | let e = Extents (ceiling w) (ceiling h) 123 | pangoIter <- Pango.layoutGetIter pangoLayout 124 | pangoBaseline <- Pango.layoutIterGetBaseline pangoIter 125 | let l = Baseline (ceiling pangoBaseline) 126 | return (e, l, pangoLayout) 127 | 128 | surfaceCacheHndl :: LRU.LruHandle (Font, Color, Text) Cairo.Surface 129 | surfaceCacheHndl = unsafePerformIO (LRU.newLruHandle 1000) 130 | {-# NOINLINE surfaceCacheHndl #-} 131 | 132 | monoChar :: 133 | forall g a. 134 | Inj (CairoElement g) a => 135 | Font {- must be monospace! -} -> 136 | g Color -> 137 | g Char -> 138 | a 139 | monoChar font gcolor gchar = 140 | inj CairoElement 141 | { cairoElementExtents = extents, 142 | cairoElementBaseline = baseline, 143 | cairoElementRender = render } 144 | where 145 | em = "M" 146 | (extents, baseline, _) = primTextPango font em 147 | 148 | render :: Offset -> CairoRender g 149 | render (Offset x y) = CairoRender $ \getG -> do 150 | let Extents w h = extents 151 | let color = getG gcolor 152 | let content = Text.singleton (getG gchar) 153 | -- TODO: take the transformation matrix into account, otherwise the text 154 | -- is scaled after rendering and becomes blurry 155 | surface <- Cairo.withTargetSurface $ \targetSurface -> 156 | Cairo.liftIO $ LRU.cached surfaceCacheHndl (font, color, content) $ do 157 | (contentExtents, _, pangoLayout) <- primTextPangoIO font content 158 | when (contentExtents /= extents) $ 159 | hPutStrLn stderr $ 160 | "monoChar: Invariant violation, " ++ show (fontFamily font) ++ " is not a monospace font.\n" ++ 161 | " sizeOf " ++ show content ++ " = " ++ show contentExtents ++ "\n" ++ 162 | " sizeOf " ++ show em ++ " = " ++ show extents 163 | -- TODO: When we know the background color, prefer "ContentColor" without "Alpha" to get 164 | -- subpixel antialiasing (instead of grayscale). 165 | s <- Cairo.createSimilarSurface targetSurface Cairo.ContentColorAlpha (fromIntegral w) (fromIntegral h) 166 | Cairo.renderWith s $ do 167 | setSourceColor color 168 | Pango.showLayout pangoLayout 169 | return s 170 | Cairo.setSourceSurface surface (fromIntegral x) (fromIntegral y) 171 | Cairo.paint 172 | -------------------------------------------------------------------------------- /src/layout/Source/Layout/Core.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | 3 | The purpose of a layouting engine is to take a description of a layout 4 | expressed using primitives (rectangles, circles, lines of text, etc) and 5 | combinators (horizontal/vertical composition, layering, centering, etc) and 6 | compute absolute coordinates for primitives on a 2-dimensional plane. 7 | 8 | We represent coordinates and distances in device units (pixels or characters) 9 | using types without a fractional component ('Natural' and 'Integer'). The reason 10 | for this is to guarantee that the resulting collage can be rendered without 11 | undesired anti-aliasing, as our focus is user interfaces and not abstract 12 | vector graphics. 13 | 14 | -} 15 | 16 | module Source.Layout.Core 17 | ( 18 | -- * Offset 19 | Offset(..), 20 | offsetAdd, 21 | offsetSub, 22 | offsetMin, 23 | offsetMax, 24 | offsetNegate, 25 | offsetZero, 26 | unsafeOffsetExtents, 27 | 28 | -- * Positioned 29 | Positioned(..), 30 | 31 | -- * Extents 32 | Extents(..), 33 | extentsAdd, 34 | extentsMax, 35 | extentsOffset, 36 | extentsWithOffset, 37 | HasExtents(..), 38 | heightOf, 39 | widthOf, 40 | 41 | -- * Margin 42 | Margin(..), 43 | marginZero, 44 | marginMax, 45 | 46 | -- * Baseline 47 | Baseline(..), 48 | baselineMin, 49 | baselineWithOffset, 50 | HasBaseline(..), 51 | 52 | -- * Collage 53 | Collage, 54 | collageSingleton, 55 | collageAnnotate, 56 | collageCompose, 57 | collageComposeN, 58 | collageExtents, 59 | collageWidth, 60 | collageHeight, 61 | collageMargin, 62 | collageBaseline, 63 | collageWithMargin, 64 | foldMapCollage, 65 | mapCollageAnnotation, 66 | 67 | -- * LRTB 68 | LRTB(..), 69 | lrtb 70 | 71 | ) where 72 | 73 | import Data.Void (Void, absurd) 74 | import Numeric.Natural (Natural) 75 | import Data.String (IsString(..)) 76 | import Data.List.NonEmpty (NonEmpty(..)) 77 | import Data.Semigroup (sconcat) 78 | 79 | import Source.Layout.Inj 80 | 81 | -- | The position of an item (relative or absolute). 82 | data Offset = 83 | Offset 84 | { offsetX :: !Integer, 85 | offsetY :: !Integer 86 | } deriving (Eq, Ord, Show) 87 | 88 | -- | Lift a binary numeric operation to offsets, 89 | -- applying it to both dimensions. 90 | offsetOp :: 91 | (Integer -> Integer -> Integer) -> 92 | (Offset -> Offset -> Offset) 93 | offsetOp (#) o1 o2 = 94 | Offset 95 | { offsetX = offsetX o1 # offsetX o2, 96 | offsetY = offsetY o1 # offsetY o2 } 97 | 98 | -- | Offset pointwise addition. 99 | -- 100 | -- >>> offsetAdd (Offset 10 20) (Offset 1 2) 101 | -- Offset {offsetX = 11, offsetY = 22} 102 | -- 103 | offsetAdd :: Offset -> Offset -> Offset 104 | offsetAdd = offsetOp (+) 105 | 106 | -- | Offset pointwise subtraction. 107 | -- 108 | -- >>> offsetSub (Offset 10 20) (Offset 1 2) 109 | -- Offset {offsetX = 9, offsetY = 18} 110 | -- 111 | offsetSub :: Offset -> Offset -> Offset 112 | offsetSub = offsetOp (-) 113 | 114 | -- | Offset pointwise minimum. 115 | -- 116 | -- >>> offsetMin (Offset 10 1) (Offset 2 20) 117 | -- Offset {offsetX = 2, offsetY = 1} 118 | -- 119 | offsetMin :: Offset -> Offset -> Offset 120 | offsetMin = offsetOp min 121 | 122 | -- | Offset pointwise maximum. 123 | -- 124 | -- >>> offsetMax (Offset 10 1) (Offset 2 20) 125 | -- Offset {offsetX = 10, offsetY = 20} 126 | -- 127 | offsetMax :: Offset -> Offset -> Offset 128 | offsetMax = offsetOp max 129 | 130 | -- | Offset pointwise negation. 131 | -- 132 | -- >>> offsetNegate (Offset 5 -10) 133 | -- Offset {offsetX = -5, offsetY = 10} 134 | -- 135 | offsetNegate :: Offset -> Offset 136 | offsetNegate (Offset x y) = Offset (negate x) (negate y) 137 | 138 | -- | Zero offset. 139 | -- 140 | -- prop> offsetAdd offsetZero a = a 141 | -- prop> offsetAdd a offsetZero = a 142 | -- prop> offsetSub a offsetZero = a 143 | -- prop> offsetSub offsetZero a = offsetNegate a 144 | -- 145 | -- Note that 'offsetZero' is /not/ an identity element for 'offsetMin' or 146 | -- 'offsetMax' becasue an offset can be negative. 147 | offsetZero :: Offset 148 | offsetZero = Offset 0 0 149 | 150 | -- | Convert an offset to extents. 151 | -- Precondition: offset is non-negative, otherwise the function 152 | -- throws @Underflow :: ArithException@. 153 | unsafeOffsetExtents :: Offset -> Extents 154 | unsafeOffsetExtents (Offset x y) = Extents (fromInteger x) (fromInteger y) 155 | 156 | -- | Positioned item. 157 | data Positioned a = At { positionedOffset :: !Offset, positionedItem :: !a } 158 | deriving (Eq, Ord, Show, Functor, Foldable, Traversable) 159 | 160 | -- | The size of an item. 161 | data Extents = 162 | Extents 163 | { extentsW :: !Natural, 164 | extentsH :: !Natural 165 | } deriving (Eq, Ord, Show) 166 | 167 | -- | Lift a binary numeric operation to extents, 168 | -- applying it to both dimensions. 169 | extentsOp :: 170 | (Natural -> Natural -> Natural) -> 171 | (Extents -> Extents -> Extents) 172 | extentsOp (#) o1 o2 = 173 | Extents 174 | { extentsW = extentsW o1 # extentsW o2, 175 | extentsH = extentsH o1 # extentsH o2 } 176 | 177 | -- | Extents pointwise addition. 178 | -- 179 | -- >>> extentsAdd (Extents 10 20) (Extents 1 2) 180 | -- Extents {extentsX = 11, extentsY = 22} 181 | -- 182 | extentsAdd :: Extents -> Extents -> Extents 183 | extentsAdd = extentsOp (+) 184 | 185 | -- | Extents pointwise maximum. 186 | -- 187 | -- >>> extentsMax (Extents 10 1) (Extents 2 20) 188 | -- Extents {extentsX = 10, extentsY = 20} 189 | -- 190 | extentsMax :: Extents -> Extents -> Extents 191 | extentsMax = extentsOp max 192 | 193 | -- | Convert extents to an offset. 194 | extentsOffset :: Extents -> Offset 195 | extentsOffset (Extents w h) = Offset (toInteger w) (toInteger h) 196 | 197 | -- | Compute the extents for a subcollage in a composition. 198 | -- 199 | -- Precondition: offset is non-negative, otherwise the function 200 | -- throws @Underflow :: ArithException@. 201 | extentsWithOffset :: Offset -> Extents -> Extents 202 | extentsWithOffset offset = extentsAdd (unsafeOffsetExtents offset) 203 | 204 | -- | A class of items that have extents. 205 | class HasExtents a where 206 | extentsOf :: a -> Extents 207 | 208 | heightOf, widthOf :: HasExtents a => a -> Natural 209 | heightOf = extentsH . extentsOf 210 | widthOf = extentsW . extentsOf 211 | 212 | -- | A minimum recommended distance from an item to any other item. 213 | data Margin = 214 | Margin 215 | { marginLeft :: !Natural, 216 | marginRight :: !Natural, 217 | marginTop :: !Natural, 218 | marginBottom :: !Natural 219 | } deriving (Eq, Ord, Show) 220 | 221 | -- | Lift a binary numeric operation to margins, 222 | -- applying it to all four directions. 223 | marginOp :: 224 | (Natural -> Natural -> Natural) -> 225 | (Margin -> Margin -> Margin) 226 | marginOp (#) m1 m2 = 227 | Margin 228 | { marginLeft = marginLeft m1 # marginLeft m2, 229 | marginRight = marginRight m1 # marginRight m2, 230 | marginTop = marginTop m1 # marginTop m2, 231 | marginBottom = marginBottom m1 # marginBottom m2 } 232 | 233 | -- | Zero margin. 234 | marginZero :: Margin 235 | marginZero = Margin 0 0 0 0 236 | 237 | -- | Margin pointwise maximum. 238 | -- 239 | -- >>> marginMax (Margin 1 10 2 20) (Margin 3 4 5 6) 240 | -- Margin {marginLeft = 3, marginRight = 10, marginTop = 5, marginBottom = 20} 241 | -- 242 | marginMax :: Margin -> Margin -> Margin 243 | marginMax = marginOp max 244 | 245 | -- | The imaginary line upon which the topmost line of text rests, expressed as 246 | -- a distance from the top edge. May not be present if the item does not 247 | -- contain text. 248 | data Baseline = NoBaseline | Baseline Natural 249 | deriving (Eq, Ord, Show) 250 | 251 | -- | Lift a binary numeric operation to baselines. 252 | baselineOp :: 253 | (Natural -> Natural -> Natural) -> 254 | (Baseline -> Baseline -> Baseline) 255 | baselineOp _ NoBaseline l2 = l2 256 | baselineOp _ l1 NoBaseline = l1 257 | baselineOp (#) (Baseline l1) (Baseline l2) = Baseline (l1 # l2) 258 | 259 | -- | Baseline minimum. 260 | -- 261 | -- >>> baselineMin (Baseline 10) (Baseline 20) 262 | -- Baseline 10 263 | -- 264 | -- >>> baselineMin (Baseline 20) NoBaseline 265 | -- Baseline 20 266 | -- 267 | baselineMin :: Baseline -> Baseline -> Baseline 268 | baselineMin = baselineOp min 269 | 270 | -- | Compute the baseline for a subcollage in a composition. 271 | -- 272 | -- Precondition: offset is non-negative, otherwise the function 273 | -- throws @Underflow :: ArithException@. 274 | baselineWithOffset :: Offset -> Baseline -> Baseline 275 | baselineWithOffset _ NoBaseline = NoBaseline 276 | baselineWithOffset offset (Baseline l1) = 277 | Baseline (l1 + fromInteger (offsetY offset)) 278 | 279 | -- | A class of items that have a baseline. 280 | class HasBaseline a where 281 | baselineOf :: a -> Baseline 282 | 283 | -- | A collage of elements. Can be created from a single element with 284 | -- 'collageSingleton' or from a combination of several subcollages with 285 | -- relative offsets from a point with 'collageComposeN'. After a collage is 286 | -- built, it can be folded with 'foldMapCollage'. 287 | -- 288 | -- Here's a visualisation of a collage with two rectangular elements: 289 | -- 290 | -- @ 291 | -- top-left corner 292 | -- / 293 | -- * +---+ 294 | -- | | 295 | -- +-+ +---+ 296 | -- | | 297 | -- +-+ * 298 | -- \\ 299 | -- bottom-right corner 300 | -- @ 301 | -- 302 | -- The bounding box (extents) of a collage is a vector from its top-left corner 303 | -- to the bottom-right corner. 304 | -- 305 | data Collage n a = 306 | Collage !Margin !Extents !Baseline !(Offset -> CollageBuilder n a) 307 | 308 | instance HasExtents (Collage n a) where 309 | extentsOf = collageExtents 310 | 311 | instance HasBaseline (Collage n a) where 312 | baselineOf = collageBaseline 313 | 314 | -- | Get the bounding box of a collage in constant time. 315 | collageExtents :: Collage n a -> Extents 316 | collageExtents (Collage _ e _ _) = e 317 | 318 | -- | Get the margin of a collage in constant time. 319 | collageMargin :: Collage n a -> Margin 320 | collageMargin (Collage m _ _ _) = m 321 | 322 | -- | Get the baseline in constant time. 323 | collageBaseline :: Collage n a -> Baseline 324 | collageBaseline (Collage _ _ l _) = l 325 | 326 | collageBuilder :: Collage n a -> Offset -> CollageBuilder n a 327 | collageBuilder (Collage _ _ _ b) = b 328 | 329 | -- | Get the width of a collage in constant time. 330 | collageWidth :: Collage n a -> Natural 331 | collageWidth = extentsW . collageExtents 332 | 333 | -- | Get the height of a collage in constant time. 334 | collageHeight :: Collage n a -> Natural 335 | collageHeight = extentsH . collageExtents 336 | 337 | -- | Set the margins of a collage to the pointwise maximum of their current 338 | -- value and the specified new value. Taking the maximum ensures we do not 339 | -- erase the margins computed from subcollages. 340 | collageWithMargin :: Margin -> Collage n a -> Collage n a 341 | collageWithMargin m' (Collage m e l b) = 342 | Collage (marginMax m' m) e l b 343 | 344 | -- | Fold over the collage elements with absolute positions, 345 | -- ordered by z-index (ascending). 346 | -- 347 | -- O(n) - linear in the amount of elements. 348 | -- 349 | -- The input offset is the position for the top-left corner of the collage. 350 | foldMapCollage :: 351 | Semigroup s => 352 | (Positioned a -> s) -> 353 | Offset -> 354 | Collage n a -> 355 | (n, s) 356 | foldMapCollage yield offset (Collage _ _ _ b) = 357 | case b offset of 358 | CollageBuilder n b' -> (n, b' yield) 359 | 360 | data CollageBuilder n a = 361 | CollageBuilder !n !(forall r. Semigroup r => (Positioned a -> r) -> r) 362 | 363 | collageBuilderSingleton :: n -> a -> Offset -> CollageBuilder n a 364 | collageBuilderSingleton n a = 365 | \offset -> CollageBuilder n ($ At offset a) 366 | 367 | instance Semigroup n => Semigroup (CollageBuilder n a) where 368 | CollageBuilder n1 b1 <> CollageBuilder n2 b2 = 369 | CollageBuilder (n1 <> n2) (b1 <> b2) 370 | 371 | -- | Construct a collage from a single element. 372 | collageSingleton :: (HasExtents a, HasBaseline a, Monoid n) => a -> Collage n a 373 | collageSingleton a = 374 | Collage marginZero (extentsOf a) (baselineOf a) (collageBuilderSingleton mempty a) 375 | 376 | instance (HasExtents a, HasBaseline a, IsString a, Monoid n) => IsString (Collage n a) where 377 | fromString = collageSingleton . fromString 378 | 379 | -- | Add an annotation to a collage. 380 | collageAnnotate :: Semigroup n => (Offset -> n) -> Collage n a -> Collage n a 381 | collageAnnotate mkann (Collage m e l b) = 382 | Collage m e l (liftA2 withAnn mkann b) 383 | where 384 | withAnn ann = mapCollageBuilderAnnotation (<> ann) 385 | 386 | -- | Modify the collage annotation. 387 | mapCollageAnnotation :: (n -> n') -> Collage n a -> Collage n' a 388 | mapCollageAnnotation f (Collage m e l b) = Collage m e l (mapCollageBuilderAnnotation f . b) 389 | 390 | mapCollageBuilderAnnotation :: (n -> n') -> CollageBuilder n a -> CollageBuilder n' a 391 | mapCollageBuilderAnnotation f (CollageBuilder n b) = CollageBuilder (f n) b 392 | 393 | -- | Combine a pair of collages by placing one atop another 394 | -- with an offset. For instance, an @'Offset' a b@ would yield 395 | -- the following result: 396 | -- 397 | -- @ 398 | -- +------------+ collage below (first argument) 399 | -- | ^ | 400 | -- | |b | 401 | -- | a v | 402 | -- | \<-\> +------------+ collage above (second argument) 403 | -- | | | 404 | -- +-----| | 405 | -- | | 406 | -- +------------+ 407 | -- @ 408 | -- 409 | -- This is a special case of 'collageComposeN'. 410 | -- 411 | collageCompose :: 412 | Semigroup n => 413 | Offset -> 414 | Collage n a -> 415 | Collage n a -> 416 | Collage n a 417 | collageCompose offset c1 c2 = 418 | positionedItem (At offsetZero c1 <> At offset c2) 419 | 420 | data MarginPoints = 421 | MarginPoints 422 | !Offset 423 | !Offset 424 | 425 | instance Semigroup MarginPoints where 426 | MarginPoints p1 q1 <> MarginPoints p2 q2 = 427 | MarginPoints (offsetMin p1 p2) (offsetMax q1 q2) 428 | 429 | toMarginPoints :: Offset -> Extents -> Margin -> MarginPoints 430 | toMarginPoints offset extents margin = MarginPoints p q 431 | where 432 | p = offsetAdd offset marginTopLeftOffset 433 | q = offsetAdd offset marginBottomRightOffset 434 | marginTopLeftOffset = 435 | Offset 436 | { offsetX = (negate . toInteger) (marginLeft margin), 437 | offsetY = (negate . toInteger) (marginTop margin) } 438 | marginBottomRightOffset = 439 | Offset 440 | { offsetX = toInteger (marginRight margin) + toInteger (extentsW extents), 441 | offsetY = toInteger (marginBottom margin) + toInteger (extentsH extents) } 442 | 443 | fromMarginPoints :: Extents -> MarginPoints -> Margin 444 | fromMarginPoints extents marginPoints = 445 | Margin 446 | { marginLeft = (intNatCeil . negate) (offsetX p), 447 | marginRight = intNatCeil (offsetX q - offsetX eOffset), 448 | marginTop = (intNatCeil . negate) (offsetY p), 449 | marginBottom = intNatCeil (offsetY q - offsetY eOffset) } 450 | where 451 | eOffset = extentsOffset extents 452 | MarginPoints p q = marginPoints 453 | 454 | intNatCeil :: Integer -> Natural 455 | intNatCeil = fromInteger . max 0 456 | 457 | -- Lazy fields to tie the knot in collageComposeN (minOffset) 458 | data CollageComposeAccum n a = 459 | CollageComposeAccum 460 | Offset 461 | MarginPoints 462 | Extents 463 | Baseline 464 | (Offset -> CollageBuilder n a) 465 | 466 | instance Semigroup n => Semigroup (CollageComposeAccum n a) where 467 | CollageComposeAccum o1 mp1 e1 l1 b1 <> CollageComposeAccum o2 mp2 e2 l2 b2 = 468 | CollageComposeAccum (offsetMin o1 o2) (mp1 <> mp2) (extentsMax e1 e2) (baselineMin l1 l2) (b1 <> b2) 469 | 470 | -- | A generalization of 'collageCompose' to take a non-empty list of 471 | -- subcollages instead of a pair. 472 | -- 473 | -- Offset common between all elements is factored out into the position of the 474 | -- resulting collage. 475 | -- 476 | collageComposeN :: 477 | forall n a. 478 | Semigroup n => 479 | NonEmpty (Positioned (Collage n a)) -> 480 | Positioned (Collage n a) 481 | collageComposeN (positionedCollage :| []) = 482 | -- This special case is an optimization and does not affect the semantics. 483 | positionedCollage 484 | collageComposeN elements = 485 | At minOffset resultCollage 486 | where 487 | resultCollage = 488 | Collage resultMargin resultExtents resultBaseline resultElements 489 | 490 | resultMargin = fromMarginPoints resultExtents resultMarginPoints 491 | 492 | (CollageComposeAccum minOffset resultMarginPoints resultExtents resultBaseline resultElements) = 493 | sconcat (fmap @NonEmpty processElement elements) 494 | 495 | processElement :: 496 | Positioned (Collage n a) -> 497 | CollageComposeAccum n a 498 | processElement (At offset collage) = 499 | let 500 | extents = collageExtents collage 501 | margin = collageMargin collage 502 | baseline = collageBaseline collage 503 | -- normalized offset, guaranteed to be non-negative 504 | offset' = offsetSub offset minOffset 505 | extents' = extentsWithOffset offset' extents 506 | baseline' = baselineWithOffset offset' baseline 507 | marginPoints = toMarginPoints offset' extents margin 508 | element' = collageBuilder collage . offsetAdd offset' 509 | in 510 | CollageComposeAccum offset marginPoints extents' baseline' element' 511 | 512 | instance Semigroup n => Semigroup (Positioned (Collage n a)) where 513 | a <> b = sconcat (a :| b : []) 514 | sconcat = collageComposeN 515 | 516 | instance (HasExtents a, HasBaseline a, Inj p a, Monoid n) => Inj p (Collage n a) where 517 | inj = collageSingleton . inj 518 | 519 | -- | A value for each side: left, right, top, bottom. 520 | data LRTB a = LRTB 521 | { left :: !a, 522 | right :: !a, 523 | top :: !a, 524 | bottom :: !a 525 | } deriving (Eq, Ord, Show, Functor, Foldable, Traversable) 526 | 527 | instance Applicative LRTB where 528 | pure a = LRTB a a a a 529 | LRTB lf rf tf bf <*> LRTB la ra ta ba = 530 | LRTB (lf la) (rf ra) (tf ta) (bf ba) 531 | 532 | instance (Inj p' a, p ~ LRTB p') => Inj p (LRTB a) where 533 | inj = fmap inj 534 | 535 | -- | Construct and inject an 'LRTB' value. 536 | lrtb :: forall p a. Inj (LRTB p) a => p -> p -> p -> p -> a 537 | lrtb l r t b = inj (LRTB l r t b) 538 | 539 | instance Num a => Num (LRTB a) where 540 | (+) = liftA2 (+) 541 | (-) = liftA2 (-) 542 | (*) = liftA2 (*) 543 | negate = fmap negate 544 | abs = fmap abs 545 | signum = fmap signum 546 | fromInteger = pure . fromInteger 547 | 548 | instance {-# OVERLAPPING #-} Inj Void (LRTB a) where 549 | inj = absurd 550 | 551 | -------------------------------------------------------------------------------- /examples/expr.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /src/driver/Source/NewGen.hs: -------------------------------------------------------------------------------- 1 | module Source.NewGen 2 | ( -- * Names 3 | SynShape, 4 | Index, 5 | 6 | -- * Types 7 | Schema (..), 8 | TyUnion, 9 | 10 | -- * Values 11 | Node (..), 12 | RecSel (..), 13 | 14 | -- * Path 15 | PathSegment (..), 16 | Path (..), 17 | emptyPath, 18 | PathBuilder, 19 | 20 | -- * Draw 21 | offsetZero, 22 | CursorBlink (..), 23 | blink, 24 | Selection (..), 25 | Paths (..), 26 | Ann, 27 | El, 28 | redrawUI, 29 | cairoPositionedElementRender, 30 | Find (..), 31 | PrecPredicate, 32 | precAllow, 33 | precAllowAll, 34 | noPrec, 35 | WritingDirection (..), 36 | LayoutCtx (..), 37 | 38 | -- * Draw (ext) 39 | layoutNodeStandalone, 40 | foldCairoCollage, 41 | getNoAnn, 42 | defaultDrawCtx, 43 | cairoRender, 44 | 45 | -- * React 46 | ReactResult (..), 47 | 48 | -- * Editor 49 | Mode (..), 50 | quitStackMode, 51 | EditorState (..), 52 | initEditorState, 53 | fromParsedValue, 54 | esExpr, 55 | esPointer, 56 | esPrecBordersAlways, 57 | esWritingDirection, 58 | esStack, 59 | esUndo, 60 | esRedo, 61 | esRenderUI, 62 | esPointerPath, 63 | esJumptags, 64 | esMode, 65 | selectionOfEditorState, 66 | reactEditorState, 67 | 68 | -- * Plugin 69 | Plugin (..), 70 | PluginInfo, 71 | mkPluginInfo, 72 | 73 | -- * Utils 74 | maybeA, 75 | ) 76 | where 77 | 78 | import Control.Applicative as A 79 | import Control.Lens as Lens hiding (Index, elements) 80 | import Control.Monad 81 | import Control.Monad.Reader 82 | import Control.Monad.State 83 | import Control.Monad.Writer 84 | import qualified Data.Char as Char 85 | import Data.DList as DList 86 | import Data.Foldable as Foldable 87 | import Data.Function (on) 88 | import Data.HashMap.Strict (HashMap) 89 | import qualified Data.HashMap.Strict as HashMap 90 | import Data.HashSet as HashSet 91 | import Data.List as List 92 | import Data.List.NonEmpty as NonEmpty 93 | import Data.Map as Map 94 | import Data.Maybe 95 | import Data.Primitive.Array as Array 96 | import Data.Semigroup 97 | import Data.Sequence as Seq 98 | import Data.Text (Text) 99 | import qualified Data.Text as Text 100 | import qualified Graphics.Rendering.Cairo as Cairo (Render) 101 | import Source.Layout.Inj 102 | import Source.Layout.NonNegative 103 | import Numeric.Natural (Natural) 104 | import Sdam.Core 105 | import Sdam.Parser 106 | import Sdam.Validator 107 | import Source.Layout.Cairo.Element 108 | import Source.Layout.Cairo.Prim.Color 109 | import Source.Layout.Cairo.Prim.Rect 110 | import Source.Layout.Cairo.Prim.Text 111 | import Source.Layout.Combinators 112 | import Source.Layout.Core 113 | import Source.Input 114 | import qualified Source.Input.KeyCode as KeyCode 115 | import Source.Plugin 116 | import Prelude hiding (seq) 117 | 118 | -------------------------------------------------------------------------------- 119 | -- Values 120 | -------------------------------------------------------------------------------- 121 | 122 | data Node = Node NodeSel (Syn Node) 123 | 124 | data NodeSel 125 | = SynSel RecSel 126 | | StrSel Int 127 | 128 | data RecSel 129 | = -- for records without children (and empty sequences) 130 | RecSel0 131 | | -- for records with children (and non-empty sequences) 132 | RecSel Index SelStatus 133 | 134 | -- The node can be in one of three states: 135 | -- 136 | -- * Self-selection, collapsed. 137 | -- * Self-selection, not collapsed. 138 | -- * Child selection. 139 | -- 140 | -- Note that a node with a child selected cannot be collapsed. 141 | -- This way we can be certain that the selected node is visible. 142 | 143 | data SelStatus = SelSelf Collapsed | SelChild 144 | 145 | newtype Collapsed = Collapsed Bool 146 | 147 | -------------------------------------------------------------------------------- 148 | ---- Validation 149 | -------------------------------------------------------------------------------- 150 | 151 | toValidationValue :: Node -> ValidationValue 152 | toValidationValue (Node _ syn) = ValidationValue (fmap toValidationValue syn) 153 | 154 | validateNode :: Schema -> Node -> ValidationResult 155 | validateNode schema node = validate schema (toValidationValue node) 156 | 157 | -------------------------------------------------------------------------------- 158 | ---- Drawing 159 | -------------------------------------------------------------------------------- 160 | 161 | jumptagLabels :: NonEmpty Char 162 | jumptagLabels = 163 | -- Dvorak-friendly, should be configurable. 164 | NonEmpty.fromList "aoeuhtnspcrjm" 165 | 166 | data CursorBlink = CursorVisible | CursorInvisible 167 | 168 | blink :: CursorBlink -> CursorBlink 169 | blink = \case 170 | CursorVisible -> CursorInvisible 171 | CursorInvisible -> CursorVisible 172 | 173 | data Selection 174 | = Selection 175 | { selectionPath :: Path, 176 | selectionTip :: SynShape, 177 | selectionTipPos :: Maybe Int 178 | } 179 | 180 | data Paths 181 | = Paths 182 | { pathsCursor :: Maybe Path, 183 | pathsSelection :: Selection 184 | } 185 | 186 | data DrawCtx 187 | = DrawCtx Selection CursorBlink 188 | | NoDrawCtx 189 | 190 | defaultDrawCtx :: DrawCtx 191 | defaultDrawCtx = NoDrawCtx 192 | 193 | textline :: 194 | Inj (CairoElement ((->) DrawCtx)) a => 195 | Color -> 196 | Font -> 197 | Text -> 198 | (DrawCtx -> Maybe Natural) -> 199 | a 200 | textline color font str cur = text font (inj color) str cur 201 | 202 | line :: Color -> Natural -> Collage Ann El 203 | line color w = rect nothing (inj color) (Extents w 1) 204 | 205 | vline :: Color -> Natural -> Collage Ann El 206 | vline color h = rect nothing (inj color) (Extents 1 h) 207 | 208 | leftOf :: Collage n El -> Integer 209 | leftOf collage = toInteger (marginLeft (collageMargin collage)) 210 | 211 | rightOf :: Extents -> Collage n El -> Integer 212 | rightOf (Extents vacantWidth _) collage = 213 | let Extents width _ = collageExtents collage 214 | mRight = marginRight (collageMargin collage) 215 | minus a b = max 0 (toInteger a - toInteger b) 216 | in vacantWidth `minus` (width + mRight) 217 | 218 | data WritingDirection = WritingDirectionLTR | WritingDirectionRTL 219 | 220 | newtype TokenCount = TokenCount Natural 221 | 222 | addTokenCount :: Int -> TokenCount -> TokenCount 223 | addTokenCount n (TokenCount k) = TokenCount (fromIntegral n + k) 224 | 225 | newtype RecLayoutFn 226 | = RecLayoutFn 227 | { appRecLayoutFn :: 228 | Path -> 229 | TokenCount -> 230 | WritingDirection -> 231 | (TokenCount, (PrecUnenclosed, Collage Ann El)) 232 | } 233 | 234 | instance Semigroup RecLayoutFn where 235 | RecLayoutFn a <> RecLayoutFn b = 236 | RecLayoutFn $ \path tc wd -> 237 | let (tc', (aUnenclosed, a')) = 238 | a path tc wd 239 | (tc'', (bUnenclosed, b')) = 240 | b path tc' wd 241 | f = case wd of 242 | WritingDirectionLTR -> horizBaseline 243 | WritingDirectionRTL -> flip horizBaseline 244 | in (tc'', (aUnenclosed <> bUnenclosed, f a' b')) 245 | 246 | nefoldr1 :: (a -> a -> a) -> NonEmpty a -> a 247 | nefoldr1 = List.foldr1 -- safe for non-empty lists 248 | 249 | data RecLayoutStyle = RecLayoutStyle {recLayoutEditMode :: Bool} 250 | 251 | data PunctList a 252 | = PunctBase Text 253 | | PunctCons Text a (PunctList a) 254 | 255 | splitEither :: (a -> Either sep b) -> [a] -> ([b], Maybe (sep, [a])) 256 | splitEither _ [] = ([], Nothing) 257 | splitEither p (a : as) = 258 | case p a of 259 | Left sep -> ([], Just (sep, as)) 260 | Right b -> mapFst (b :) (splitEither p as) 261 | 262 | mapFst :: (a -> a') -> (a, b) -> (a', b) 263 | mapFst f (a, b) = (f a, b) 264 | 265 | matchTokenNode :: Token a -> Either a Char 266 | matchTokenNode (TokenChar c) = Right c 267 | matchTokenNode (TokenNode a) = Left a 268 | 269 | parseSynPunctList :: [Token a] -> PunctList a 270 | parseSynPunctList ts = 271 | case splitEither matchTokenNode ts of 272 | (s, Nothing) -> PunctBase (Text.pack s) 273 | (s, Just (node, ts')) -> PunctCons (Text.pack s) node (parseSynPunctList ts') 274 | 275 | synRows :: PunctList a -> NonEmpty (PunctList a) 276 | synRows (PunctBase "/") = PunctBase "" :| [PunctBase ""] 277 | synRows (PunctBase p) = PunctBase p :| [] 278 | synRows (PunctCons "/" a ps) = 279 | let p' :| ps' = synRows ps 280 | in PunctBase "" :| PunctCons "" a p' : ps' 281 | synRows (PunctCons p a ps) = 282 | let p' :| ps' = synRows ps 283 | in PunctCons p a p' :| ps' 284 | 285 | synToLayout :: RecLayoutStyle -> Syn (PrecUnenclosed, Collage Ann El) -> RecLayoutFn 286 | synToLayout rs syn = 287 | nefoldr1 vsep $ fmap (shapeRowToLayout rs) rows 288 | where 289 | rows = synRows (parseSynPunctList (Foldable.toList (synTokens syn))) 290 | RecLayoutFn a `vsep` RecLayoutFn b = 291 | RecLayoutFn $ \path tc wd -> 292 | let (tc', (aUnenclosed, a')) = 293 | a path tc wd 294 | (tc'', (bUnenclosed, b')) = 295 | b path (addTokenCount 1 tc') wd 296 | f = case wd of 297 | WritingDirectionLTR -> vertLeft 298 | WritingDirectionRTL -> vertRight 299 | maxWidth = (max `on` widthOf) a' b' 300 | in (tc'', (aUnenclosed <> bUnenclosed, a' `f` line light1 maxWidth `f` b')) 301 | 302 | shapeRowToLayout :: RecLayoutStyle -> PunctList (PrecUnenclosed, Collage Ann El) -> RecLayoutFn 303 | shapeRowToLayout rs row = 304 | case nonEmpty (shapeRowToLayouts rs row) of 305 | Nothing -> punctToLayout "" 306 | Just row' -> sconcat row' 307 | 308 | shapeRowToLayouts :: RecLayoutStyle -> PunctList (PrecUnenclosed, Collage Ann El) -> [RecLayoutFn] 309 | shapeRowToLayouts rs (PunctBase p) = punctToLayouts rs p 310 | shapeRowToLayouts rs (PunctCons p fld l) = 311 | punctToLayouts rs p <> [fieldToLayout fld] <> shapeRowToLayouts rs l 312 | 313 | fieldToLayout :: (PrecUnenclosed, Collage Ann El) -> RecLayoutFn 314 | fieldToLayout fld = RecLayoutFn $ \_ tc _ -> (addTokenCount 1 tc, fld) 315 | 316 | punctToLayouts :: RecLayoutStyle -> Text -> [RecLayoutFn] 317 | punctToLayouts rs "" | not (recLayoutEditMode rs) = [] 318 | punctToLayouts _ p = [punctToLayout p] 319 | 320 | punctToLayout :: Text -> RecLayoutFn 321 | punctToLayout s = 322 | RecLayoutFn $ \path tc _ -> 323 | let tc' = addTokenCount (Text.length s) tc 324 | a = 325 | textline 326 | light1 327 | ubuntuFont 328 | s 329 | (\drawCtx -> blinkingCursorPos path drawCtx >>= adjustByTokenCount tc) 330 | a' = if jumptagFits then layoutWithJumptag path a else a 331 | jumptagFits = widthOf a >= jumptagLabelMaxWidth 332 | in (tc', (mempty, a')) 333 | where 334 | adjustByTokenCount (TokenCount k) pos 335 | | pos >= k, 336 | let pos' = pos - k, 337 | pos' <= fromIntegral (Text.length s) = 338 | Just pos' 339 | adjustByTokenCount _ _ = Nothing 340 | 341 | blinkingCursorPos :: Path -> DrawCtx -> Maybe Natural 342 | blinkingCursorPos path (DrawCtx selection CursorVisible) 343 | | selectionPath selection == path, 344 | Just pos <- selectionTipPos selection = 345 | Just (fromIntegral pos) 346 | blinkingCursorPos _ _ = Nothing 347 | 348 | layoutWithJumptag :: Path -> Collage Ann El -> Collage Ann El 349 | layoutWithJumptag path = 350 | collageAnnotate (\o -> (mempty, mempty, pathJumptag o)) 351 | where 352 | pathJumptag offset = DList.singleton (Jumptag offset path) 353 | 354 | newtype Find a b = Find (a -> Maybe b) 355 | 356 | instance Semigroup (Find a b) where 357 | Find f1 <> Find f2 = 358 | Find $ \a -> f1 a <|> f2 a 359 | 360 | instance Monoid (Find a b) where 361 | mempty = Find (const Nothing) 362 | 363 | type FindPath = Find Offset Path 364 | 365 | type FindZone = Find Path (Offset, Extents) 366 | 367 | data Jumptag = Jumptag Offset Path 368 | 369 | -- Collage elements: 370 | type El = CairoElement ((->) DrawCtx) 371 | 372 | -- Collage annotations: 373 | type Ann = (FindPath, FindZone, DList Jumptag) 374 | 375 | getNoAnn :: ((), a) -> a 376 | getNoAnn = snd 377 | 378 | renderStackNodes :: Offset -> Collage () (CairoElement g) -> Paths -> FindZone -> CairoRender g 379 | renderStackNodes fallbackOffset stackLayout Paths {pathsSelection} (Find findZone) = 380 | getNoAnn $ foldCairoCollage offset stackLayout 381 | where 382 | offset = 383 | case findZone (selectionPath pathsSelection) of 384 | Just (o, e) -> 385 | Offset 386 | { offsetX = offsetX o + toInteger (marginLeft (collageMargin stackLayout) + extentsW e), 387 | offsetY = offsetY o 388 | } 389 | Nothing -> fallbackOffset 390 | 391 | renderSelectionBorder :: Paths -> FindZone -> CairoRender Identity 392 | renderSelectionBorder Paths {pathsSelection} (Find findZone) = 393 | case findZone (selectionPath pathsSelection) of 394 | Just (o, e) -> 395 | getNoAnn 396 | $ foldCairoCollage o 397 | $ outline 2 color e 398 | Nothing -> mempty 399 | where 400 | color = 401 | case selectionTipPos pathsSelection of 402 | Nothing -> selectionBorderColor 403 | Just _ -> inputBorderColor 404 | 405 | renderHoverBorder :: Paths -> FindZone -> CairoRender Identity 406 | renderHoverBorder Paths {pathsCursor} (Find findZone) = 407 | case pathsCursor of 408 | Just p 409 | | Just (o, e) <- findZone p -> 410 | getNoAnn 411 | $ foldCairoCollage o 412 | $ outline 2 hoverBorderColor e 413 | _ -> mempty 414 | 415 | renderJumptagLabels :: NonEmpty (Char, Jumptag) -> CairoRender Identity 416 | renderJumptagLabels = foldMap renderJumptagLabel 417 | 418 | renderJumptagLabel :: (Char, Jumptag) -> CairoRender Identity 419 | renderJumptagLabel (c, Jumptag o _) = 420 | getNoAnn $ foldCairoCollage o $ layoutJumptagLabel c 421 | 422 | layoutJumptagLabel :: Monoid n => Char -> Collage n (CairoElement Identity) 423 | layoutJumptagLabel c = 424 | substrate 1 (rect nothing dark2) $ 425 | text ubuntuMonoFont (rgb 255 127 80) label nothing 426 | where 427 | label = Text.toUpper (Text.singleton c) 428 | 429 | jumptagLabelMaxWidth :: Natural 430 | jumptagLabelMaxWidth = 431 | maximum @NonEmpty $ 432 | fmap (widthOf . layoutJumptagLabel @()) jumptagLabels 433 | 434 | findPathInBox :: Path -> (Offset, Extents) -> FindPath 435 | findPathInBox p box = 436 | Find $ \point -> 437 | if insideBox box point 438 | then Just p 439 | else Nothing 440 | 441 | findBoxAtPath :: Path -> (Offset, Extents) -> FindZone 442 | findBoxAtPath p box = 443 | Find $ \p' -> 444 | if p == p' 445 | then Just box 446 | else Nothing 447 | 448 | dark1, dark1', dark2, light1, white, red :: Inj Color a => a 449 | dark1 = grayscale 41 450 | dark1' = grayscale 35 451 | dark2 = grayscale 77 452 | light1 = grayscale 179 453 | white = grayscale 255 454 | red = rgb 255 0 0 455 | 456 | selectionBorderColor, 457 | hoverBorderColor, 458 | stackBorderColor, 459 | inputBorderColor :: 460 | Inj Color a => a 461 | selectionBorderColor = rgb 94 80 134 462 | hoverBorderColor = rgb 255 127 80 463 | stackBorderColor = rgb 45 134 108 464 | inputBorderColor = rgb 45 134 108 465 | 466 | textWithCursor :: Text -> (DrawCtx -> Maybe Natural) -> Collage Ann El 467 | textWithCursor = textline white ubuntuFont 468 | 469 | textWithoutCursor :: Text -> Collage Ann El 470 | textWithoutCursor t = textWithCursor t nothing 471 | 472 | outline :: 473 | Inj (CairoElement f) a => 474 | Inj1 f (Maybe (LRTB (NonNegative Double))) => 475 | Natural -> 476 | f (Maybe Color) -> 477 | Extents -> 478 | a 479 | outline width = rect (inj (Just outlineWidth)) 480 | where 481 | outlineWidth :: LRTB (NonNegative Double) 482 | outlineWidth = pure (fromIntegral width) 483 | 484 | punct :: 485 | Inj (CairoElement ((->) DrawCtx)) a => 486 | Text -> 487 | a 488 | punct t = textline light1 ubuntuFont t nothing 489 | 490 | ubuntuFont :: Font 491 | ubuntuFont = Font "Ubuntu" 12 FontWeightNormal 492 | 493 | ubuntuMonoFont :: Font 494 | ubuntuMonoFont = Font "Ubuntu Mono" 12 FontWeightNormal 495 | 496 | lrtbMargin :: Margin -> LRTB Natural 497 | lrtbMargin (Margin l r t b) = lrtb l r t b 498 | 499 | substrateMargin :: 500 | Semigroup n => 501 | (Extents -> Collage n a) -> 502 | Collage n a -> 503 | Collage n a 504 | substrateMargin f a = 505 | substrate (lrtbMargin (collageMargin a)) f a 506 | 507 | foldCairoCollage :: Offset -> Collage n (CairoElement g) -> (n, CairoRender g) 508 | foldCairoCollage = foldMapCollage cairoPositionedElementRender 509 | 510 | -------------------------------------------------------------------------------- 511 | ---- Utils 512 | -------------------------------------------------------------------------------- 513 | 514 | maybeA :: Alternative f => Maybe a -> f a 515 | maybeA = maybe A.empty A.pure 516 | 517 | alwaysSucceed :: Alternative f => f () -> f () 518 | alwaysSucceed f = f <|> pure () 519 | 520 | -------------------------------------------------------------------------------- 521 | ---- Input Mode 522 | -------------------------------------------------------------------------------- 523 | 524 | newtype InputTrie = InputTrie (Map Char (Either InputTrie Char)) 525 | 526 | instance Semigroup InputTrie where 527 | InputTrie m1 <> InputTrie m2 = 528 | InputTrie $ Map.unionWith f m1 m2 529 | where 530 | f (Right c) _ = Right c 531 | f _ (Right c) = Right c 532 | f (Left t1) (Left t2) = Left (t1 <> t2) 533 | 534 | instance Monoid InputTrie where 535 | mempty = InputTrie Map.empty 536 | 537 | buildInputTrie :: [(String, Char)] -> InputTrie 538 | buildInputTrie = foldMap pairToInputTrie 539 | where 540 | pairToInputTrie (s, c) = go c s 541 | go _ [] = error "buildInputTrie: bad input" 542 | go c [k] = InputTrie (Map.singleton k (Right c)) 543 | go c (k : ks) = InputTrie (Map.singleton k (Left (go c ks))) 544 | 545 | initialInputTrie :: InputTrie 546 | initialInputTrie = 547 | buildInputTrie 548 | [ ("_", '_'), 549 | ("\\", '\\'), 550 | ("lam", 'λ'), 551 | ("forall", '∀'), 552 | ("Pi", 'Π'), 553 | ("star", '★'), 554 | ("all", '∗'), 555 | ("box", '□'), 556 | ("->", '→'), 557 | ("<-", '←'), 558 | ("not", '¬') 559 | ] 560 | 561 | -------------------------------------------------------------------------------- 562 | ---- Editor 563 | -------------------------------------------------------------------------------- 564 | 565 | defaultHole :: Node 566 | defaultHole = Node (SynSel RecSel0) (Syn Seq.empty) 567 | 568 | isHole :: Node -> Bool 569 | isHole (Node _ syn) = Seq.null (synTokens syn) 570 | 571 | data JumpAction 572 | = JumpSelect 573 | | JumpCopyTo Path 574 | 575 | data Mode 576 | = ModeNormal 577 | | ModeStack 578 | | ModeJump (NonEmpty (Char, Jumptag)) JumpAction 579 | | ModeInput Text InputTrie 580 | | ModeStackInput 581 | 582 | quitStackMode :: Mode -> Mode 583 | quitStackMode ModeStack = ModeNormal 584 | quitStackMode mode = mode 585 | 586 | data EditorState 587 | = EditorState 588 | { _esExpr :: Node, 589 | _esPointer :: Offset, 590 | _esPrecBordersAlways :: Bool, 591 | _esWritingDirection :: WritingDirection, 592 | _esStack :: [Node], 593 | _esUndo :: [Node], 594 | _esRedo :: [Node], 595 | _esRenderUI :: CursorBlink -> Cairo.Render (), 596 | _esPointerPath :: Maybe Path, 597 | _esJumptags :: [Jumptag], 598 | _esMode :: Mode 599 | } 600 | 601 | initEditorState :: EditorState 602 | initEditorState = 603 | EditorState 604 | { _esExpr = defaultHole, 605 | _esPointer = offsetZero, 606 | _esPrecBordersAlways = False, 607 | _esWritingDirection = WritingDirectionLTR, 608 | _esStack = [], 609 | _esUndo = [], 610 | _esRedo = [], 611 | _esRenderUI = const (pure ()), 612 | _esPointerPath = Nothing, 613 | _esJumptags = [], 614 | _esMode = ModeNormal 615 | } 616 | 617 | data LayoutCtx 618 | = LayoutCtx 619 | { _lctxPath :: PathBuilder, 620 | _lctxValidationResult :: ValidationResult, 621 | _lctxViewport :: Extents, 622 | _lctxPrecBordersAlways :: Bool, 623 | _lctxPrecInfo :: HashMap SynShape (Array PrecPredicate), 624 | _lctxShapeNames :: HashMap SynShape ShapeName, 625 | _lctxPlaceholder :: Maybe Text, 626 | _lctxPrecPredicate :: PrecPredicate, 627 | _lctxWritingDirection :: WritingDirection 628 | } 629 | 630 | data ReactCtx 631 | = ReactCtx 632 | { _rctxJumptags :: [Jumptag] 633 | } 634 | 635 | data ReactState 636 | = ReactState 637 | { _rstNode :: Node, 638 | _rstStack :: [Node], 639 | _rstMode :: Mode 640 | } 641 | 642 | -------------------------------------------------------------------------------- 643 | ---- Lenses 644 | -------------------------------------------------------------------------------- 645 | 646 | makeLenses ''EditorState 647 | 648 | makeLenses ''LayoutCtx 649 | 650 | makeLenses ''ReactCtx 651 | 652 | makeLenses ''ReactState 653 | 654 | -------------------------------------------------------------------------------- 655 | ---- Utils 656 | -------------------------------------------------------------------------------- 657 | 658 | keyLetter :: Char -> KeyCode -> Bool 659 | keyLetter c keyCode = keyChar keyCode == Just c 660 | 661 | keyCodeLetter :: KeyCode -> Char -> InputEvent -> Bool 662 | keyCodeLetter kc c = \case 663 | KeyPress [] keyCode -> keyCode == kc || keyLetter c keyCode 664 | _ -> False 665 | 666 | -------------------------------------------------------------------------------- 667 | ---- Editor - Layout 668 | -------------------------------------------------------------------------------- 669 | 670 | redrawUI :: 671 | PluginInfo -> 672 | Extents -> 673 | EditorState -> 674 | EditorState 675 | redrawUI pluginInfo viewport es = 676 | es 677 | & esRenderUI .~ renderUI 678 | & esPointerPath .~ cursor 679 | & esJumptags .~ jumptags 680 | where 681 | lctx = 682 | LayoutCtx 683 | { _lctxPath = mempty @PathBuilder, 684 | _lctxValidationResult = mempty, 685 | _lctxViewport = viewport, 686 | _lctxPrecBordersAlways = es ^. esPrecBordersAlways, 687 | _lctxPrecInfo = pluginInfoPrecInfo pluginInfo, 688 | _lctxShapeNames = pluginInfoShapeNames pluginInfo, 689 | _lctxPlaceholder = Nothing, 690 | _lctxPrecPredicate = precAllowAll, 691 | _lctxWritingDirection = es ^. esWritingDirection 692 | } 693 | schema = pluginInfoSchema pluginInfo 694 | pointer = es ^. esPointer 695 | infoBarLayout = layoutInfoBar lctx es 696 | stackLayout = layoutNodesStack lctx (es ^. esStack) 697 | mainLayout = layoutMainExpr schema lctx (es ^. esExpr) 698 | hOff :: Collage n a -> Integer 699 | hOff c = 700 | toInteger (heightOf infoBarLayout) 701 | + toInteger (marginTop (collageMargin c)) 702 | + 10 703 | mainOffset = 704 | Offset 705 | { offsetX = leftOf mainLayout + 10, 706 | offsetY = hOff mainLayout 707 | } 708 | stackFallbackOffset = 709 | Offset 710 | { offsetX = rightOf (lctx ^. lctxViewport) stackLayout, 711 | offsetY = hOff stackLayout 712 | } 713 | backgroundRdr = 714 | getNoAnn 715 | $ foldCairoCollage offsetZero 716 | $ rect nothing dark1 (lctx ^. lctxViewport) 717 | ((Find findPath, findZone, jumptags'), mainRdr) = 718 | foldCairoCollage mainOffset mainLayout 719 | infoBarRdr = getNoAnn $ foldCairoCollage offsetZero infoBarLayout 720 | jumptags = DList.toList jumptags' 721 | stackNodesVisible = 722 | case es ^. esMode of 723 | ModeStack -> True 724 | ModeStackInput -> True 725 | _ -> False 726 | stackRdr = 727 | if stackNodesVisible 728 | then renderStackNodes stackFallbackOffset stackLayout paths findZone 729 | else mempty 730 | jumptagsRdr = case es ^. esMode of 731 | ModeJump activeJumptags _ -> renderJumptagLabels activeJumptags 732 | _ -> mempty 733 | cursor = findPath pointer 734 | selection = selectionOfEditorState es 735 | paths = Paths {pathsCursor = cursor, pathsSelection = selection} 736 | renderUI cursorBlink = do 737 | cairoRender backgroundRdr runIdentity 738 | cairoRender mainRdr ($ DrawCtx selection cursorBlink) 739 | cairoRender (renderSelectionBorder paths findZone) runIdentity 740 | cairoRender (renderHoverBorder paths findZone) runIdentity 741 | cairoRender jumptagsRdr runIdentity 742 | cairoRender stackRdr ($ defaultDrawCtx) 743 | cairoRender infoBarRdr ($ DrawCtx selection cursorBlink) 744 | 745 | layoutMainExpr :: 746 | Schema -> 747 | LayoutCtx -> 748 | Node -> 749 | Collage Ann El 750 | layoutMainExpr schema lctx expr = collage 751 | where 752 | lctx' n = lctx {_lctxValidationResult = validateNode schema n} 753 | (_, collage) = layoutNode (lctx' expr) expr 754 | 755 | layoutNodesStack :: Monoid n => LayoutCtx -> [Node] -> Collage n El 756 | layoutNodesStack lctx nodes = 757 | case nonEmpty nodes of 758 | Nothing -> layoutStackDecoration $ punct "end of stack" 759 | Just ns -> nefoldr1 vertLeft (NonEmpty.map (layoutNodeStack lctx) ns) 760 | 761 | layoutNodeStack :: Monoid n => LayoutCtx -> Node -> Collage n El 762 | layoutNodeStack lctx node = 763 | mapCollageAnnotation (const mempty) 764 | $ layoutStackDecoration 765 | $ snd (layoutNode lctx' node) 766 | where 767 | lctx' = lctx {_lctxValidationResult = mempty} 768 | 769 | layoutStackDecoration :: Monoid n => Collage n El -> Collage n El 770 | layoutStackDecoration = 771 | collageWithMargin (Margin 4 4 4 4) 772 | . substrate 0 backgroundRect 773 | . substrate 4 (outline 2 stackBorderColor) 774 | where 775 | backgroundRect = rect nothing dark1' 776 | 777 | layoutNodeStandalone :: Monoid n => LayoutCtx -> Node -> Collage n El 778 | layoutNodeStandalone lctx node = 779 | mapCollageAnnotation (const mempty) 780 | $ substrate 0 backgroundRect 781 | $ substrate 4 (outline 2 stackBorderColor) 782 | $ snd (layoutNode lctx' node) 783 | where 784 | lctx' = lctx {_lctxValidationResult = mempty} 785 | backgroundRect = rect nothing dark1' 786 | 787 | layoutInfoBar :: 788 | Monoid n => 789 | LayoutCtx -> 790 | EditorState -> 791 | Collage n El 792 | layoutInfoBar lctx es = 793 | case es ^. esMode of 794 | ModeInput acc (InputTrie t) -> 795 | mapCollageAnnotation (const mempty) 796 | $ substrate 0 (rect nothing inputBorderColor . extentsMax e) 797 | $ textWithoutCursor ("\\" <> acc <> "[" <> Text.pack (Map.keys t) <> "]") 798 | _ -> 799 | mapCollageAnnotation (const mempty) 800 | $ substrate 0 (rect nothing selectionBorderColor . extentsMax e) 801 | $ textWithoutCursor (pprSelection (lctx ^. lctxShapeNames) (selectionOfEditorState es)) 802 | where 803 | e = Extents 804 | { extentsW = extentsW (lctx ^. lctxViewport), 805 | extentsH = 15 806 | } 807 | 808 | pprSelection :: HashMap SynShape ShapeName -> Selection -> Text 809 | pprSelection shapeNames selection = Text.pack (goPath selectionPath "") 810 | where 811 | Selection {selectionPath, selectionTip, selectionTipPos} = selection 812 | goPath p = 813 | case unconsPath p of 814 | Nothing -> goTip selectionTip . goTipPos selectionTipPos 815 | Just (ps, p') -> goPathSegment ps . (" → " ++) . goPath p' 816 | goTip shape = 817 | case HashMap.lookup shape shapeNames of 818 | Nothing -> (pprShape shape ++) 819 | Just a -> (Text.unpack (shapeName a) ++) 820 | goTipPos Nothing = id 821 | goTipPos (Just pos) = (" [" ++) . shows pos . (']' :) 822 | goPathSegment (PathSegment shape i) = 823 | case HashMap.lookup shape shapeNames of 824 | Nothing -> (pprShape shape ++) . (" [" ++) . shows (indexToInt i) . (']' :) 825 | Just a -> (Text.unpack (pprNamedShape a i) ++) 826 | pprNamedShape a i = 827 | shapeName a 828 | <> " [" 829 | <> Array.indexArray (shapeFieldNames a) (indexToInt i) 830 | <> "]" 831 | pprShape = concatMap escape . flattenSynShape 832 | escape '\n' = "\\n" 833 | escape c = [c] 834 | 835 | layoutNode :: LayoutCtx -> Node -> (PrecUnenclosed, Collage Ann El) 836 | layoutNode lctx (Node (SynSel synSel) _) 837 | | isNodeCollapsed synSel = layoutCollapsed lctx 838 | layoutNode lctx (Node sel syn) 839 | | Just lit <- to_lit lfields = layoutLit recLayoutStyle lctx lit 840 | | Just seq <- to_seq lfields = layoutSeq recLayoutStyle lctx seq 841 | | Just str <- to_str lfields = layoutStr lctx str 842 | | otherwise = layoutRec recLayoutStyle lctx lfields 843 | where 844 | lfields = layoutFields recLayoutStyle lctx syn 845 | recLayoutStyle = 846 | case sel of 847 | StrSel _ -> RecLayoutStyle {recLayoutEditMode = True} 848 | SynSel _ -> RecLayoutStyle {recLayoutEditMode = False} 849 | 850 | layoutFields :: 851 | RecLayoutStyle -> 852 | LayoutCtx -> 853 | Syn Node -> 854 | Syn (PrecUnenclosed, Collage Ann El) 855 | layoutFields rs lctx syn = 856 | syn & traversed %@~ \(intToIndex -> i) -> 857 | layoutNode 858 | $ lctxResetPrecEditMode 859 | $ lctxDescent (PathSegment shape i) 860 | $ lctx 861 | where 862 | shape = synShape syn 863 | lctxResetPrecEditMode 864 | | recLayoutEditMode rs = lctxPrecPredicate .~ noPrec 865 | | otherwise = id 866 | 867 | layoutCollapsed :: LayoutCtx -> (PrecUnenclosed, Collage Ann El) 868 | layoutCollapsed lctx = 869 | (,) (mempty @PrecUnenclosed) 870 | $ layoutSel (BorderValid precBorder) path 871 | $ layoutWithJumptag path 872 | $ punct "…" 873 | where 874 | precBorder = PrecBorder (lctx ^. lctxPrecBordersAlways) 875 | path = buildPath (lctx ^. lctxPath) 876 | 877 | layoutLit :: 878 | RecLayoutStyle -> 879 | LayoutCtx -> 880 | Seq (Token (PrecUnenclosed, Collage Ann El)) -> 881 | (PrecUnenclosed, Collage Ann El) 882 | layoutLit rs lctx lit = 883 | (,) (guardUnenclosed precBorder precUnenclosed) 884 | $ layoutSel (toBorder lctx precBorder) path 885 | $ collage 886 | where 887 | (precUnenclosed, collage) = 888 | snd $ appRecLayoutFn layoutFn path (TokenCount 0) wd 889 | precBorder = 890 | PrecBorder (lctx ^. lctxPrecBordersAlways) 891 | <> appPrecPredicate (lctx ^. lctxPrecPredicate) precUnenclosed 892 | layoutFn = 893 | punctToLayout "“" <> shapeRowToLayout rs pl <> punctToLayout "”" 894 | where 895 | pl = parseSynPunctList (Foldable.toList lit) 896 | path = buildPath (lctx ^. lctxPath) 897 | wd = lctx ^. lctxWritingDirection 898 | 899 | layoutStr :: 900 | LayoutCtx -> 901 | Text -> 902 | (PrecUnenclosed, Collage Ann El) 903 | layoutStr lctx str = 904 | (,) (mempty @PrecUnenclosed) 905 | $ layoutSel (toBorder lctx precBorder) path 906 | $ layoutWithJumptag path 907 | $ holeOverlay 908 | $ textWithCursor str (blinkingCursorPos path) 909 | where 910 | precBorder = 911 | PrecBorder (lctx ^. lctxPrecBordersAlways) 912 | <> PrecBorder (Text.any Char.isSpace str) 913 | path = buildPath (lctx ^. lctxPath) 914 | hole = textline dark2 ubuntuFont ("_" <> fromMaybe "" (lctx ^. lctxPlaceholder)) nothing 915 | holeOverlay 916 | | Text.null str = collageCompose offsetZero hole 917 | | otherwise = id 918 | 919 | lctxDescent :: PathSegment -> LayoutCtx -> LayoutCtx 920 | lctxDescent pathSegment lctx = 921 | lctx 922 | & lctxPath %~ (<> mkPathBuilder pathSegment) 923 | & lctxValidationResult %~ pathTrieLookup pathSegment 924 | & lctxPlaceholder .~ placeholder 925 | & lctxPrecPredicate .~ precPredicate 926 | where 927 | PathSegment shape i = pathSegment 928 | placeholder = 929 | case HashMap.lookup shape (lctx ^. lctxShapeNames) of 930 | Nothing -> Nothing 931 | Just a -> Just (Array.indexArray (shapeFieldNames a) (indexToInt i)) 932 | precPredicate 933 | | Just _ <- to_seq shape = precAllowAll 934 | | Just precInfo <- HashMap.lookup shape (lctx ^. lctxPrecInfo) = 935 | Array.indexArray precInfo (indexToInt i) 936 | | otherwise = noPrec 937 | 938 | layoutRec :: 939 | RecLayoutStyle -> 940 | LayoutCtx -> 941 | Syn (PrecUnenclosed, Collage Ann El) -> 942 | (PrecUnenclosed, Collage Ann El) 943 | layoutRec rs lctx syn = 944 | (,) (guardUnenclosed precBorder precUnenclosed') 945 | $ layoutSel (toBorder lctx precBorder) path 946 | $ collage 947 | where 948 | shape = synShape syn 949 | (precUnenclosed, collage) = 950 | snd $ appRecLayoutFn (synToLayout rs syn) path (TokenCount 0) wd 951 | precUnenclosed' = addUnenclosed shape precUnenclosed 952 | precBorder = 953 | PrecBorder (lctx ^. lctxPrecBordersAlways) 954 | <> appPrecPredicate (lctx ^. lctxPrecPredicate) precUnenclosed' 955 | path = buildPath (lctx ^. lctxPath) 956 | wd = lctx ^. lctxWritingDirection 957 | 958 | layoutSeq :: 959 | RecLayoutStyle -> 960 | LayoutCtx -> 961 | [(PrecUnenclosed, Collage Ann El)] -> 962 | (PrecUnenclosed, Collage Ann El) 963 | layoutSeq rs lctx seq = 964 | (,) (guardUnenclosed precBorder precUnenclosed) 965 | $ layoutSel (toBorder lctx precBorder) path 966 | $ collage 967 | where 968 | (precUnenclosed, collage) = 969 | snd $ appRecLayoutFn layoutFn path (TokenCount 0) wd 970 | precBorder = 971 | PrecBorder (lctx ^. lctxPrecBordersAlways) 972 | <> appPrecPredicate (lctx ^. lctxPrecPredicate) precUnenclosed 973 | layoutFn = 974 | case nonEmpty seq of 975 | Nothing -> punctToLayout "|" 976 | Just seq' -> 977 | if recLayoutEditMode rs 978 | then punctToLayout "|" <> rowsLayout seq' 979 | else nefoldr1 vcat (fmap (addB . fieldToLayout) seq') 980 | rowsLayout (h :| hs) = 981 | case nonEmpty hs of 982 | Nothing -> fieldToLayout h <> emptyPunctLayout 983 | Just hs' -> vcat (fieldToLayout h <> emptyPunctLayout) (rowsLayout hs') 984 | emptyPunctLayout = punctToLayout "" 985 | path = buildPath (lctx ^. lctxPath) 986 | wd = lctx ^. lctxWritingDirection 987 | 988 | addB :: RecLayoutFn -> RecLayoutFn 989 | addB (RecLayoutFn x) = 990 | RecLayoutFn $ \path tc wd -> 991 | let (tc', (xUnenclosed, x')) = 992 | x path tc wd 993 | g = case wd of 994 | WritingDirectionLTR -> horizTop 995 | WritingDirectionRTL -> flip horizTop 996 | in (tc', (xUnenclosed, vline dark2 (heightOf x') `g` x')) 997 | 998 | vcat :: RecLayoutFn -> RecLayoutFn -> RecLayoutFn 999 | RecLayoutFn a `vcat` RecLayoutFn b = 1000 | RecLayoutFn $ \path tc wd -> 1001 | let (tc', (aUnenclosed, a')) = 1002 | a path tc wd 1003 | (tc'', (bUnenclosed, b')) = 1004 | b path tc' wd 1005 | f = case wd of 1006 | WritingDirectionLTR -> vertLeft 1007 | WritingDirectionRTL -> vertRight 1008 | in (tc'', (aUnenclosed <> bUnenclosed, a' `f` b')) 1009 | 1010 | to_lit :: Syn a -> Maybe (Seq (Token a)) 1011 | to_lit (synTokens -> Seq.viewl -> TokenChar '"' Seq.:< ts) = Just ts 1012 | to_lit _ = Nothing 1013 | 1014 | to_str :: Syn a -> Maybe Text 1015 | to_str syn 1016 | | Foldable.null syn = 1017 | Just (Text.pack [c | TokenChar c <- Foldable.toList (synTokens syn)]) 1018 | to_str _ = Nothing 1019 | 1020 | to_seq :: Syn a -> Maybe [a] 1021 | to_seq (synTokens -> Foldable.toList -> TokenChar '|' : init_ts) = to_seq' init_ts 1022 | where 1023 | to_seq' [] = Just [] 1024 | to_seq' (TokenChar _ : _) = Nothing 1025 | to_seq' (TokenNode n : ts) = (n :) <$> to_seq' ts 1026 | to_seq _ = Nothing 1027 | 1028 | data Border = BorderValid PrecBorder | BorderInvalid 1029 | 1030 | layoutSel :: Border -> Path -> Collage Ann El -> Collage Ann El 1031 | layoutSel border path = 1032 | collageWithMargin (mkMargin (marginWidth - borderWidth)) 1033 | . collageAnnotateMargin pathZone 1034 | . layoutBorder borderWidth border 1035 | . collageWithMargin (mkMargin marginWidth) 1036 | where 1037 | mkMargin a = Margin a a a a 1038 | (marginWidth, borderWidth) = (4, 1) 1039 | pathZone box = (findPath, findZone, mempty) 1040 | where 1041 | findPath = findPathInBox path box 1042 | findZone = findBoxAtPath path box 1043 | 1044 | layoutBorder :: Natural -> Border -> Collage Ann El -> Collage Ann El 1045 | layoutBorder borderWidth = \case 1046 | BorderInvalid -> addBorder red 1047 | BorderValid (PrecBorder True) -> addBorder dark2 1048 | BorderValid (PrecBorder False) -> id 1049 | where 1050 | addBorder color = 1051 | substrateMargin (outline borderWidth color) 1052 | 1053 | toBorder :: LayoutCtx -> PrecBorder -> Border 1054 | toBorder lctx 1055 | | validChild = BorderValid 1056 | | otherwise = const BorderInvalid 1057 | where 1058 | allowUnknownShapes = HashSet.filter (not . isUnknownShapeError) 1059 | isUnknownShapeError (UnknownShape _) = True 1060 | isUnknownShapeError _ = False 1061 | validChild = 1062 | HashSet.null (allowUnknownShapes (pathTrieRoot (lctx ^. lctxValidationResult))) 1063 | 1064 | -------------------------------------------------------------------------------- 1065 | ---- Editor - Selection 1066 | -------------------------------------------------------------------------------- 1067 | 1068 | selectionOfEditorState :: EditorState -> Selection 1069 | selectionOfEditorState es = selectionOfNode (es ^. esExpr) 1070 | 1071 | selectionOfNode :: Node -> Selection 1072 | selectionOfNode = \case 1073 | Node (StrSel pos) syn -> Selection emptyPath (synShape syn) (Just pos) 1074 | Node (SynSel recSel) syn -> 1075 | case recSel of 1076 | RecSel0 -> Selection emptyPath (synShape syn) Nothing 1077 | RecSel _ (SelSelf _) -> Selection emptyPath (synShape syn) Nothing 1078 | RecSel i SelChild -> 1079 | let pathSegment = PathSegment (synShape syn) i 1080 | recField = syn ^?! synIx i 1081 | Selection pathTail tip tipPos = selectionOfNode recField 1082 | in Selection (consPath pathSegment pathTail) tip tipPos 1083 | 1084 | -- | Set self-selection for all nodes. 1085 | resetPathNode :: Node -> Node 1086 | resetPathNode (Node nodeSel syn) = 1087 | Node nodeSel' (fmap resetPathNode syn) 1088 | where 1089 | nodeSel' = 1090 | case nodeSel of 1091 | SynSel sel -> SynSel (toRecSelSelf sel) 1092 | StrSel _ -> doneEditing syn 1093 | 1094 | updatePathNode :: Path -> Node -> Node 1095 | updatePathNode path node = case node of 1096 | Node (StrSel _) _ -> node 1097 | Node (SynSel sel) syn -> 1098 | case unconsPath path of 1099 | Nothing -> Node (SynSel (toRecSelSelf sel)) syn 1100 | Just (PathSegment shape i, path') -> 1101 | if shape /= synShape syn || hasn't (synIx i) syn 1102 | then node 1103 | else 1104 | Node 1105 | (SynSel (RecSel i SelChild)) 1106 | (over (synIx i) (updatePathNode path') syn) 1107 | 1108 | setPathNode :: Path -> Node -> Node 1109 | setPathNode path node = updatePathNode path (resetPathNode node) 1110 | 1111 | toSelSelf :: SelStatus -> SelStatus 1112 | toSelSelf SelChild = SelSelf (Collapsed False) 1113 | toSelSelf selStatus@(SelSelf _collapsed) = selStatus 1114 | 1115 | toRecSelSelf :: RecSel -> RecSel 1116 | toRecSelSelf RecSel0 = RecSel0 1117 | toRecSelSelf (RecSel i selStatus) = RecSel i (toSelSelf selStatus) 1118 | 1119 | toRecSelChild :: RecSel -> Maybe RecSel 1120 | toRecSelChild RecSel0 = Nothing 1121 | toRecSelChild (RecSel i _) = Just (RecSel i SelChild) 1122 | 1123 | toggleNodeCollapse :: RecSel -> Maybe RecSel 1124 | toggleNodeCollapse (RecSel i selStatus) = 1125 | toggleSelStatusCollapse selStatus <&> \selStatus' -> 1126 | RecSel i selStatus' 1127 | toggleNodeCollapse _ = Nothing 1128 | 1129 | toggleSelStatusCollapse :: SelStatus -> Maybe SelStatus 1130 | toggleSelStatusCollapse SelChild = Nothing 1131 | toggleSelStatusCollapse (SelSelf collapsed) = 1132 | Just (SelSelf (toggleCollapsed collapsed)) 1133 | 1134 | toggleCollapsed :: Collapsed -> Collapsed 1135 | toggleCollapsed (Collapsed c) = Collapsed (not c) 1136 | 1137 | isNodeCollapsed :: RecSel -> Bool 1138 | isNodeCollapsed (RecSel _ selStatus) = isSelStatusCollapsed selStatus 1139 | isNodeCollapsed _ = False 1140 | 1141 | isSelStatusCollapsed :: SelStatus -> Bool 1142 | isSelStatusCollapsed SelChild = False 1143 | isSelStatusCollapsed (SelSelf (Collapsed c)) = c 1144 | 1145 | -------------------------------------------------------------------------------- 1146 | ---- Editor - React 1147 | -------------------------------------------------------------------------------- 1148 | 1149 | setUndoFlag :: MonadWriter UndoFlag m => m () 1150 | setUndoFlag = tell (UndoFlag True) 1151 | 1152 | newtype UndoFlag = UndoFlag Bool 1153 | 1154 | instance Semigroup UndoFlag where 1155 | UndoFlag u1 <> UndoFlag u2 = UndoFlag (u1 || u2) 1156 | 1157 | instance Monoid UndoFlag where 1158 | mempty = UndoFlag False 1159 | 1160 | data ReactResult a = UnknownEvent | ReactOk a 1161 | 1162 | reactEditorState :: 1163 | PluginInfo -> 1164 | InputEvent -> 1165 | EditorState -> 1166 | ReactResult EditorState 1167 | reactEditorState _ (PointerMotion x y) es = 1168 | ReactOk $ 1169 | es & esPointer .~ Offset (fromIntegral x) (fromIntegral y) 1170 | reactEditorState pluginInfo ButtonPress es 1171 | | Just p <- es ^. esPointerPath, 1172 | ModeJump _ jumpAction <- es ^. esMode, 1173 | let act = commitJumpAction p jumpAction, 1174 | Just es' <- runReactM_EditorState pluginInfo act es = 1175 | ReactOk es' 1176 | reactEditorState _ ButtonPress es 1177 | | Just p <- es ^. esPointerPath = 1178 | ReactOk $ 1179 | es 1180 | & esExpr %~ setPathNode p 1181 | & esMode .~ ModeNormal 1182 | reactEditorState _ (KeyPress [Control] keyCode) es 1183 | | keyLetter 'b' keyCode = 1184 | ReactOk $ es & esPrecBordersAlways %~ not 1185 | | keyLetter 'w' keyCode = 1186 | ReactOk $ 1187 | es & esWritingDirection %~ \case 1188 | WritingDirectionLTR -> WritingDirectionRTL 1189 | WritingDirectionRTL -> WritingDirectionLTR 1190 | | keyLetter 'z' keyCode, 1191 | (u : us) <- es ^. esUndo, 1192 | let expr = es ^. esExpr = 1193 | ReactOk $ 1194 | es 1195 | & esExpr .~ u 1196 | & esUndo .~ us 1197 | & esRedo %~ (expr :) 1198 | | keyLetter 'r' keyCode, 1199 | (r : rs) <- es ^. esRedo, 1200 | let expr = es ^. esExpr = 1201 | ReactOk $ 1202 | es 1203 | & esExpr .~ r 1204 | & esRedo .~ rs 1205 | & esUndo %~ (expr :) 1206 | reactEditorState pluginInfo inputEvent es 1207 | | Just act <- 1208 | getAction 1209 | (es ^. esWritingDirection) 1210 | (selectionOfNode (es ^. esExpr)) 1211 | (es ^. esMode) 1212 | inputEvent, 1213 | Just es' <- runReactM_EditorState pluginInfo (applyActionM act) es = 1214 | ReactOk es' 1215 | reactEditorState _ _ _ = UnknownEvent 1216 | 1217 | runReactM_EditorState :: 1218 | PluginInfo -> 1219 | ReactM ReactState -> 1220 | EditorState -> 1221 | Maybe EditorState 1222 | runReactM_EditorState _ act editorState = 1223 | case runReactM_ReactState act rctx rst of 1224 | Nothing -> Nothing 1225 | Just (UndoFlag undoFlag, rst') -> 1226 | let editorState' = 1227 | editorState 1228 | & esExpr .~ (rst' ^. rstNode) 1229 | & esStack .~ (rst' ^. rstStack) 1230 | & esMode .~ (rst' ^. rstMode) 1231 | in Just $ 1232 | if undoFlag 1233 | then 1234 | editorState' 1235 | & esUndo %~ ((editorState ^. esExpr) :) 1236 | & esRedo .~ [] 1237 | else editorState' 1238 | where 1239 | rst = 1240 | ReactState 1241 | { _rstNode = editorState ^. esExpr, 1242 | _rstStack = editorState ^. esStack, 1243 | _rstMode = editorState ^. esMode 1244 | } 1245 | rctx = 1246 | ReactCtx 1247 | { _rctxJumptags = editorState ^. esJumptags 1248 | } 1249 | 1250 | data Action 1251 | = ActionEscapeTransientMode 1252 | | ActionDeleteNode Path 1253 | | ActionPushStack Path 1254 | | ActionPopSwapStack Path 1255 | | ActionRotateStack 1256 | | ActionDropStack 1257 | | ActionDeleteCharBackward Path 1258 | | ActionDeleteCharForward Path 1259 | | ActionMoveStrCursorBackward Path 1260 | | ActionMoveStrCursorForward Path 1261 | | ActionInsertToken Path (Token Node) 1262 | | ActionSelectParent Path 1263 | | ActionSelectChild Path 1264 | | ActionSelectSiblingBackward Path 1265 | | ActionSelectSiblingForward Path 1266 | | ActionActivateJumptags JumpAction 1267 | | ActionJumptagLookup Char 1268 | | ActionToggleCollapse Path 1269 | | ActionToggleEditMode Path 1270 | | ActionEnterInputMode 1271 | | ActionInputSelectSymbol Path Char 1272 | | ActionInsertTokenFromStack Path 1273 | | ActionEnterStackInputMode 1274 | 1275 | getAction :: 1276 | WritingDirection -> 1277 | Selection -> 1278 | Mode -> 1279 | InputEvent -> 1280 | Maybe Action 1281 | getAction _ _ _ inputEvent 1282 | -- Escape transient modes (enter normal mode) 1283 | | KeyPress [] KeyCode.Escape <- inputEvent = 1284 | Just ActionEscapeTransientMode 1285 | getAction wd selection ModeNormal inputEvent = 1286 | getActionInModeNormal wd selection inputEvent 1287 | getAction wd selection ModeStack inputEvent = 1288 | getActionInModeStack selection inputEvent <|> getActionInModeNormal wd selection inputEvent 1289 | getAction _ _ (ModeJump _ _) inputEvent = 1290 | case inputEvent of 1291 | KeyPress [] (keyChar -> Just c) -> 1292 | Just $ ActionJumptagLookup c 1293 | _ -> Nothing 1294 | getAction _ Selection {selectionPath} ModeStackInput inputEvent = 1295 | case inputEvent of 1296 | -- Rotate the stack in input mode. 1297 | KeyPress [] keyCode 1298 | | keyLetter 'r' keyCode -> 1299 | Just $ ActionRotateStack 1300 | -- Pop a node from the stack in input mode. 1301 | KeyPress [] keyCode 1302 | | keyLetter 'p' keyCode -> 1303 | Just $ ActionInsertTokenFromStack selectionPath 1304 | _ -> Nothing 1305 | getAction _ Selection {selectionPath} (ModeInput acc _) inputEvent = 1306 | case inputEvent of 1307 | -- Enter stack input mode. 1308 | KeyPress [] keyCode 1309 | | keyLetter 'r' keyCode, 1310 | Text.null acc -> 1311 | Just $ ActionEnterStackInputMode 1312 | -- Select symbol in input mode. 1313 | KeyPress mods (keyChar -> Just c) 1314 | | Control `notElem` mods -> 1315 | Just $ ActionInputSelectSymbol selectionPath c 1316 | _ -> Nothing 1317 | 1318 | getActionInModeNormal :: 1319 | WritingDirection -> 1320 | Selection -> 1321 | InputEvent -> 1322 | Maybe Action 1323 | getActionInModeNormal 1324 | wd 1325 | Selection {selectionPath, selectionTipPos} 1326 | inputEvent 1327 | -- Enter edit mode from normal mode. 1328 | | KeyPress [] KeyCode.Space <- inputEvent = 1329 | Just (ActionToggleEditMode selectionPath) 1330 | -- Quit from edit mode with a Space. 1331 | -- Use Shift-Space to enter a space character. 1332 | | Just _ <- selectionTipPos, 1333 | KeyPress [] KeyCode.Space <- inputEvent = 1334 | Just (ActionToggleEditMode selectionPath) 1335 | -- Delete character backward. 1336 | | Just _ <- selectionTipPos, 1337 | KeyPress [] KeyCode.Backspace <- inputEvent = 1338 | Just $ ActionDeleteCharBackward selectionPath 1339 | -- Delete character forward. 1340 | | Just _ <- selectionTipPos, 1341 | KeyPress [] KeyCode.Delete <- inputEvent = 1342 | Just $ ActionDeleteCharForward selectionPath 1343 | -- Move string cursor backward. 1344 | | Just _ <- selectionTipPos, 1345 | KeyPress [] KeyCode.ArrowLeft <- inputEvent = 1346 | Just $ ActionMoveStrCursorBackward selectionPath 1347 | -- Move string cursor forward. 1348 | | Just _ <- selectionTipPos, 1349 | KeyPress [] KeyCode.ArrowRight <- inputEvent = 1350 | Just $ ActionMoveStrCursorForward selectionPath 1351 | -- Insert token. 1352 | | Just _ <- selectionTipPos, 1353 | KeyPress mods keyCode <- inputEvent, 1354 | Control `notElem` mods, 1355 | Just c <- keyChar keyCode = 1356 | Just $ 1357 | case c of 1358 | '\\' -> ActionEnterInputMode 1359 | '_' -> ActionInsertToken selectionPath (TokenNode defaultHole) 1360 | _ -> ActionInsertToken selectionPath (TokenChar c) 1361 | -- Toggle node collapse. 1362 | | KeyPress [] keyCode <- inputEvent, 1363 | keyLetter 'c' keyCode = 1364 | Just $ ActionToggleCollapse selectionPath 1365 | -- Enter jumptag mode to select a node. 1366 | | KeyPress [] keyCode <- inputEvent, 1367 | keyLetter 'g' keyCode = 1368 | Just $ ActionActivateJumptags JumpSelect 1369 | -- Enter jumptag mode to copy a node. 1370 | | KeyPress [Shift] keyCode <- inputEvent, 1371 | keyLetter 'Y' keyCode = 1372 | Just $ ActionActivateJumptags (JumpCopyTo selectionPath) 1373 | -- Delete node. 1374 | | keyCodeLetter KeyCode.Delete 'x' inputEvent = 1375 | Just $ ActionDeleteNode selectionPath 1376 | -- Push a node to the stack. 1377 | | KeyPress [] keyCode <- inputEvent, 1378 | keyLetter 'y' keyCode = 1379 | Just $ ActionPushStack selectionPath 1380 | -- Pop/swap a node from the stack. 1381 | | KeyPress [] keyCode <- inputEvent, 1382 | keyLetter 'p' keyCode = 1383 | Just $ ActionPopSwapStack selectionPath 1384 | -- Rotate stack. 1385 | | KeyPress [] keyCode <- inputEvent, 1386 | keyLetter 'r' keyCode = 1387 | Just ActionRotateStack 1388 | -- Select parent node. 1389 | | keyCodeLetter KeyCode.ArrowUp 'k' inputEvent = 1390 | Just $ ActionSelectParent selectionPath 1391 | -- Select child node. 1392 | | keyCodeLetter KeyCode.ArrowDown 'j' inputEvent = 1393 | Just $ ActionSelectChild selectionPath 1394 | -- Select sibling node left. 1395 | | keyCodeLetter KeyCode.ArrowLeft 'h' inputEvent = 1396 | Just $ case wd of 1397 | WritingDirectionLTR -> ActionSelectSiblingBackward selectionPath 1398 | WritingDirectionRTL -> ActionSelectSiblingForward selectionPath 1399 | -- Select sibling node right. 1400 | | keyCodeLetter KeyCode.ArrowRight 'l' inputEvent = 1401 | Just $ case wd of 1402 | WritingDirectionLTR -> ActionSelectSiblingForward selectionPath 1403 | WritingDirectionRTL -> ActionSelectSiblingBackward selectionPath 1404 | getActionInModeNormal _ _ _ = Nothing 1405 | 1406 | getActionInModeStack :: 1407 | Selection -> 1408 | InputEvent -> 1409 | Maybe Action 1410 | getActionInModeStack Selection {selectionPath} inputEvent 1411 | -- Enter edit mode from stack mode. 1412 | | KeyPress [] KeyCode.Space <- inputEvent = 1413 | Just (ActionToggleEditMode selectionPath) 1414 | -- Drop a node from the stack. 1415 | | KeyPress [] keyCode <- inputEvent, 1416 | keyLetter 'x' keyCode = 1417 | Just ActionDropStack 1418 | getActionInModeStack _ _ = Nothing 1419 | 1420 | type ReactM s = WriterT UndoFlag (ReaderT ReactCtx (StateT s Maybe)) () 1421 | 1422 | runReactM_ReactState :: ReactM ReactState -> ReactCtx -> ReactState -> Maybe (UndoFlag, ReactState) 1423 | runReactM_ReactState act rctx rst = 1424 | flip runStateT rst 1425 | $ flip runReaderT rctx 1426 | $ execWriterT 1427 | $ act 1428 | 1429 | applyActionM :: Action -> ReactM ReactState 1430 | applyActionM ActionEscapeTransientMode = do 1431 | rstMode .= ModeNormal 1432 | rstNode %= quitEditMode 1433 | applyActionM (ActionDeleteNode path) = do 1434 | rstMode .= ModeStack 1435 | nodes <- 1436 | zoom (rstNode . atPath path) $ do 1437 | node <- get 1438 | guard (not (isHole node)) 1439 | put defaultHole 1440 | return [node] 1441 | forM_ nodes $ \node -> 1442 | rstStack %= (node :) 1443 | setUndoFlag 1444 | applyActionM (ActionPushStack path) = do 1445 | rstMode .= ModeStack 1446 | parent <- use rstNode 1447 | let nodes = List.filter (not . isHole) (parent ^.. atPath path) 1448 | forM_ nodes $ \node -> 1449 | rstStack %= (node :) 1450 | applyActionM (ActionPopSwapStack path) = do 1451 | rstMode .= ModeStack 1452 | n : ns <- use rstStack 1453 | rstStack .= ns 1454 | popSwapNode path n 1455 | applyActionM ActionRotateStack = do 1456 | mode <- use rstMode 1457 | case mode of 1458 | ModeStack -> rstStack %= rotate 1459 | ModeStackInput -> rstStack %= rotate 1460 | _ -> rstMode .= ModeStack 1461 | applyActionM ActionDropStack = do 1462 | rstStack %= List.drop 1 1463 | applyActionM (ActionDeleteCharBackward path) = do 1464 | nodes <- 1465 | zoom (rstNode . atPath path) $ do 1466 | Node (StrSel pos) (Syn tokens) <- get 1467 | guard (pos > 0) 1468 | let (before, after) = Seq.splitAt pos tokens 1469 | (tokens', deleted) <- 1470 | case Seq.viewr before of 1471 | Seq.EmptyR -> A.empty 1472 | before' Seq.:> deleted -> 1473 | return (before' <> after, deleted) 1474 | put $ Node (StrSel (pos - 1)) (Syn tokens') 1475 | case deleted of 1476 | TokenNode node | not (isHole node) -> return [node] 1477 | _ -> return [] 1478 | forM_ nodes $ \node -> 1479 | rstStack %= (node :) 1480 | setUndoFlag 1481 | applyActionM (ActionDeleteCharForward path) = do 1482 | nodes <- 1483 | zoom (rstNode . atPath path) $ do 1484 | Node (StrSel pos) (Syn tokens) <- get 1485 | guard (pos < Seq.length tokens) 1486 | let (before, after) = Seq.splitAt pos tokens 1487 | (tokens', deleted) <- 1488 | case Seq.viewl after of 1489 | Seq.EmptyL -> A.empty 1490 | deleted Seq.:< after' -> 1491 | return (before <> after', deleted) 1492 | put $ Node (StrSel pos) (Syn tokens') 1493 | case deleted of 1494 | TokenNode node | not (isHole node) -> return [node] 1495 | _ -> return [] 1496 | forM_ nodes $ \node -> 1497 | rstStack %= (node :) 1498 | setUndoFlag 1499 | applyActionM (ActionMoveStrCursorBackward path) = 1500 | zoom (rstNode . atPath path) $ do 1501 | Node (StrSel pos) syn <- get 1502 | guard (pos > 0) 1503 | let pos' = pos - 1 1504 | put $ Node (StrSel pos') syn 1505 | applyActionM (ActionMoveStrCursorForward path) = 1506 | zoom (rstNode . atPath path) $ do 1507 | Node (StrSel pos) syn <- get 1508 | guard (pos < Seq.length (synTokens syn)) 1509 | let pos' = pos + 1 1510 | put $ Node (StrSel pos') syn 1511 | applyActionM (ActionInsertToken path t) = 1512 | zoom (rstNode . atPath path) $ do 1513 | Node (StrSel pos) (Syn tokens) <- get 1514 | let tokens' = Seq.insertAt pos t tokens 1515 | pos' = pos + 1 1516 | put $ Node (StrSel pos') (Syn tokens') 1517 | setUndoFlag 1518 | applyActionM (ActionSelectParent path) = do 1519 | rstMode %= quitStackMode 1520 | path' <- maybeA (pathParent path) 1521 | zoom (rstNode . atPath path') $ do 1522 | Node (SynSel sel) syn <- get 1523 | put $ Node (SynSel (toRecSelSelf sel)) syn 1524 | applyActionM (ActionSelectChild path) = do 1525 | rstMode %= quitStackMode 1526 | zoom (rstNode . atPath path) $ do 1527 | Node (SynSel sel) syn <- get 1528 | sel' <- maybeA (toRecSelChild sel) 1529 | put $ Node (SynSel sel') syn 1530 | applyActionM (ActionToggleCollapse path) = do 1531 | rstMode %= quitStackMode 1532 | zoom (rstNode . atPath path) $ do 1533 | Node (SynSel sel) syn <- get 1534 | sel' <- maybeA (toggleNodeCollapse sel) 1535 | put $ Node (SynSel sel') syn 1536 | applyActionM (ActionSelectSiblingBackward path) = do 1537 | rstMode %= quitStackMode 1538 | path' <- maybeA (pathParent path) 1539 | zoom rstNode $ zoomPathPrefix path' $ do 1540 | Node (SynSel (RecSel i SelChild)) syn <- get 1541 | i' <- maybeA (indexPred i) 1542 | put $ Node (SynSel (RecSel i' SelChild)) syn 1543 | applyActionM (ActionSelectSiblingForward path) = do 1544 | rstMode %= quitStackMode 1545 | path' <- maybeA (pathParent path) 1546 | zoom rstNode $ zoomPathPrefix path' $ do 1547 | Node (SynSel (RecSel i SelChild)) syn <- get 1548 | let n = Foldable.length syn 1549 | i' <- maybeA (indexSucc n i) 1550 | put $ Node (SynSel (RecSel i' SelChild)) syn 1551 | applyActionM (ActionActivateJumptags jumpAction) = do 1552 | Just jumptags <- views rctxJumptags nonEmpty 1553 | rstMode .= ModeJump (withJumptagLabels jumptags) jumpAction 1554 | applyActionM (ActionJumptagLookup c) = do 1555 | ModeJump activeJumptags jumpAction <- use rstMode 1556 | activeJumptags' <- 1557 | maybeA 1558 | $ nonEmpty 1559 | $ List.map (\(_, jt) -> jt) 1560 | $ NonEmpty.filter (\(c', _) -> c == c') 1561 | $ activeJumptags 1562 | case activeJumptags' of 1563 | Jumptag _ path :| [] -> commitJumpAction path jumpAction 1564 | jumptags -> rstMode .= ModeJump (withJumptagLabels jumptags) jumpAction 1565 | applyActionM (ActionToggleEditMode path) = do 1566 | rstMode .= ModeNormal 1567 | rstNode . atPath path 1568 | %= \(Node nodeSel syn) -> 1569 | let nodeSel' = 1570 | case nodeSel of 1571 | StrSel _ -> doneEditing syn 1572 | SynSel _ -> StrSel (Seq.length (synTokens syn)) 1573 | in Node nodeSel' syn 1574 | applyActionM ActionEnterInputMode = do 1575 | rstMode .= ModeInput "" initialInputTrie 1576 | applyActionM ActionEnterStackInputMode = do 1577 | rstMode .= ModeStackInput 1578 | applyActionM (ActionInputSelectSymbol path c) = do 1579 | ModeInput acc (InputTrie t) <- use rstMode 1580 | case Map.lookup c t of 1581 | Nothing -> rstMode .= ModeNormal 1582 | Just (Left t') -> rstMode .= ModeInput (acc <> Text.singleton c) t' 1583 | Just (Right c') -> do 1584 | rstMode .= ModeNormal 1585 | applyActionM (ActionInsertToken path (TokenChar c')) 1586 | applyActionM (ActionInsertTokenFromStack path) = do 1587 | rstMode .= ModeNormal 1588 | alwaysSucceed $ do 1589 | n : ns <- use rstStack 1590 | rstStack .= ns 1591 | applyActionM (ActionInsertToken path (TokenNode n)) 1592 | 1593 | quitEditMode :: Node -> Node 1594 | quitEditMode (Node (StrSel _) syn) = Node (doneEditing syn) syn 1595 | quitEditMode (Node nodeSel@(SynSel (RecSel i SelChild)) syn) = 1596 | Node nodeSel (over (synIx i) quitEditMode syn) 1597 | quitEditMode node = node 1598 | 1599 | synIx :: Index -> Traversal' (Syn a) a 1600 | synIx i = traversed . Lens.index (indexToInt i) 1601 | 1602 | doneEditing :: Syn Node -> NodeSel 1603 | doneEditing syn = 1604 | SynSel $ 1605 | if Foldable.null syn 1606 | then RecSel0 1607 | else RecSel (intToIndex 0) SelChild 1608 | 1609 | withJumptagLabels :: NonEmpty b -> NonEmpty (Char, b) 1610 | withJumptagLabels = NonEmpty.zip (NonEmpty.cycle jumptagLabels) 1611 | 1612 | commitJumpAction :: Path -> JumpAction -> ReactM ReactState 1613 | commitJumpAction path jumpAction = do 1614 | alwaysSucceed $ 1615 | case jumpAction of 1616 | JumpSelect -> do 1617 | rstNode %= quitEditMode 1618 | rstNode %= setPathNode path 1619 | JumpCopyTo destinationPath -> do 1620 | Just sourceNode <- uses rstNode (preview (atPath path)) 1621 | guard (not (isHole sourceNode)) 1622 | zoom (rstNode . atPath destinationPath) $ do 1623 | node <- get 1624 | guard (isHole node) 1625 | setUndoFlag 1626 | put sourceNode 1627 | rstMode .= ModeNormal 1628 | 1629 | popSwapNode :: Path -> Node -> ReactM ReactState 1630 | popSwapNode path n = do 1631 | nodes <- 1632 | zoom (rstNode . atPath path) $ do 1633 | node <- get 1634 | put n 1635 | setUndoFlag 1636 | if isHole node 1637 | then return [] 1638 | else return [node] 1639 | for_ nodes $ \node -> do 1640 | rstMode .= ModeStack 1641 | rstStack %= (node :) 1642 | 1643 | rotate :: [a] -> [a] 1644 | rotate [] = [] 1645 | rotate (x : xs) = xs ++ [x] 1646 | 1647 | pathParent :: Path -> Maybe Path 1648 | pathParent (Path ps) = 1649 | case List.reverse ps of 1650 | [] -> Nothing 1651 | _ : ps' -> Just (Path (List.reverse ps')) 1652 | 1653 | atPath :: Path -> Traversal' Node Node 1654 | atPath p = 1655 | case unconsPath p of 1656 | Nothing -> id 1657 | Just (ps, p') -> atPathSegment ps . atPath p' 1658 | 1659 | atPathSegment :: PathSegment -> Traversal' Node Node 1660 | atPathSegment (PathSegment shape i) = 1661 | \f node -> 1662 | case node of 1663 | Node sel syn | shape == synShape syn -> Node sel <$> synIx i f syn 1664 | _ -> pure node 1665 | 1666 | zoomPathPrefix :: Path -> ReactM Node -> ReactM Node 1667 | zoomPathPrefix p m = 1668 | case unconsPath p of 1669 | Nothing -> m 1670 | Just (ps, p') -> 1671 | zoom (atPathSegment ps) (zoomPathPrefix p' m) <|> m 1672 | 1673 | indexPred :: Index -> Maybe Index 1674 | indexPred i = 1675 | let i' = indexToInt i 1676 | in if i' > 0 then Just (intToIndex (i' - 1)) else Nothing 1677 | 1678 | indexSucc :: Int -> Index -> Maybe Index 1679 | indexSucc n i = 1680 | let i' = indexToInt i + 1 1681 | in if i' < n then Just (intToIndex i') else Nothing 1682 | 1683 | -------------------------------------------------------------------------------- 1684 | ---- PluginInfo 1685 | -------------------------------------------------------------------------------- 1686 | 1687 | -- | A plugin as consumed by the editor, with additional information 1688 | -- derived from the user specification. 1689 | data PluginInfo 1690 | = PluginInfo 1691 | { pluginInfoSchema :: Schema, 1692 | pluginInfoPrecInfo :: HashMap SynShape (Array PrecPredicate), 1693 | pluginInfoShapeNames :: HashMap SynShape ShapeName 1694 | } 1695 | 1696 | mkPluginInfo :: Plugin -> PluginInfo 1697 | mkPluginInfo plugin = 1698 | PluginInfo 1699 | { pluginInfoSchema = pluginSchema plugin, 1700 | pluginInfoPrecInfo = pluginPrecInfo plugin, 1701 | pluginInfoShapeNames = pluginShapeNames plugin 1702 | } 1703 | 1704 | -------------------------------------------------------------------------------- 1705 | ---- Parsing 1706 | -------------------------------------------------------------------------------- 1707 | 1708 | fromParsedValue :: ParsedValue -> Node 1709 | fromParsedValue = go 1710 | where 1711 | go (ParsedValue syn) = Node (mkNodeSel syn) (fmap go syn) 1712 | mkNodeSel syn = 1713 | SynSel $ 1714 | if Foldable.null syn 1715 | then RecSel0 1716 | else RecSel (intToIndex 0) (SelSelf (Collapsed False)) 1717 | --------------------------------------------------------------------------------