Commit d604c6a4 authored by Marc Coiffier's avatar Marc Coiffier
Browse files

Integrate the 'curly-gui' and 'definitive-graphics' packages from old projects

parent d8338e3e
......@@ -16,7 +16,7 @@ module Curly.Core(
LogLevel(..),LogMessage(..),serialWriteHBytes,addLogCallback,removeLogCallback,withLogCallback,envLogLevel,logLine,logMessage,logAction,trylogLevel,trylog,liftIOLog,cyDebug,
-- * Misc
B64Chunk(..),PortNumber,watchFile,connectTo,(*+),cacheFileName,createFileDirectory,
Compressed(..),noCurlySuf,(</>),format
Compressed(..),noCurlySuf,(</>),format,
) where
import Codec.Compression.Zlib (compress,decompress)
......
# Revision history for curly-gui
## 0.1.0.0 -- YYYY-mm-dd
* First version. Released on an unsuspecting world.
This diff is collapsed.
-XRebindableSyntax
-XNoMonomorphismRestriction
-XTypeOperators
-XViewPatterns
-XFlexibleInstances
-XFlexibleContexts
-XMultiParamTypeClasses
-XFunctionalDependencies
-XTupleSections
-XRankNTypes
-XExistentialQuantification
-XGeneralizedNewtypeDeriving
-XRecursiveDo
-XImplicitParams
-O4
import Distribution.Simple
main = defaultMain
-- Initial curly-gui.cabal generated by cabal init. For further
-- documentation, see http://haskell.org/cabal/users-guide/
name: curly-gui
version: 0.1.0.0
-- synopsis:
-- description:
license: GPL-3
license-file: LICENSE
author: Marc Coiffier
maintainer: marc.coiffier@univ-grenoble-alpes.fr
-- copyright:
category: Language
build-type: Simple
extra-source-files: CHANGELOG.md
cabal-version: >=1.10
executable curly-gui
main-is: Curly/GUI.hs
-- other-modules:
-- other-extensions:
default-extensions: RebindableSyntax
NoMonomorphismRestriction
TypeOperators
ViewPatterns
FlexibleInstances
FlexibleContexts
MultiParamTypeClasses
FunctionalDependencies
TupleSections
RankNTypes
ExistentialQuantification
GeneralizedNewtypeDeriving
RecursiveDo
ImplicitParams
build-depends: base >=4.9 && <4.10, definitive-base, definitive-graphics, curly-core, curly, definitive-network, definitive-parser
hs-source-dirs: exe
default-language: Haskell2010
module Main where
import Definitive
import Graphics.Widget
import System.Environment
import Data.IORef
import Curly.Core
import Curly.Core.Documentation
import Curly.Core.Peers
import Curly.Core.Library
import Curly.Core.VCS
import Curly.Core.Security
import Curly.UI
import Curly.Style
import IO.Network.Socket
import Language.Format
import Paths_curly_gui
showLeafDoc x = do
term <- setupTermFromEnv
putStrLn $ docString term ?style (x^.leafDoc)
main = let ?style = defaultStyle in void $ runApplication $ mdo
initCurly getDataFileName
let nextTab delta = runDynamicState display $ do
l <- getl children
when (nonempty l) $ do selected =~ \n -> (n+delta)`mod`length l
notebookLabel deleteTab txt = do
img <- (boxChild.clickable) (image (Icon IS_SmallToolbar "window-close")) <| do
packing =~ set expands Fitting . set padding 4
onChange (lastClick 1) $ \_ _ -> deleteTab
lbl <- (boxChild.clickable) (text txt) <| do
onChange (lastClick 3) $ \_ _ -> do
mi <- accelMenuItem "Close tab" <| do onChange lastActivation $ \_ _ -> deleteTab
m <- menu [mi]
setDynamic m visible True
hideable (box2 Horizontal lbl img) <| do visible =- True
addTab x = runDynamicState display (children =~ (+[x]))
delTab x = runDynamicState display (children =~ refuse (==x))
runDynamicState ?application $ do
shortcuts =~ insert "<Ctrl>q" (Assoc "Quit" quitApplication)
shortcuts =~ insert "<Ctrl>l" (Assoc "Go to address" $ do
setDynamic addressBar hasFocus True)
shortcuts =~ insert "<Ctrl>w" (Assoc "Delete current tab" $ do
l <- runDynamicState display $ do
i <- getl selected
children `swapWith` \l -> let (h,t) = splitAt i l
in h+drop 1 t
when (empty l) quitApplication)
shortcuts =~ insert "<Ctrl>o" (Assoc "Open file" $ do
setDynamic fcDialog visible True)
shortcuts =~ insert "<Ctrl>Page_Up" (Assoc "Next tab" (nextTab 1))
shortcuts =~ insert "<Ctrl>Page_Down" (Assoc "Previous tab" (nextTab (-1)))
shortcuts =~ insert "<Ctrl>r" (Assoc "Manage repositories" $ do
setDynamic repoDialog visible True)
shortcuts =~ insert "<Ctrl>t" (Assoc "Switch to next tab" $ do
runDynamicState display $ do
cs <- getl children
selected =~ \i -> (i+1) `mod` length cs)
addressBar <- (boxChild.focusable.keyboardEnabled) textInput <| do
hasFocus =- True
let updateCombo = do
h <- getDynamic addressBar label
insts <- try (return []) $ do
h <- connectTo h curlyPort
fold <$> runConnection Just True h (exchange AskInstances)
runDynamicState instanceChoice $ do alternatives =- insts
selected =- 0
onHigh (lastKey GDK_KEY_Return . sat (\(_,x) -> x==Pressed)) $ \_ -> updateCombo
onHigh (hasFocus.sat not) $ \_ -> updateCombo
instanceChoice <- boxChild (comboBox [])
launchButton <- (boxChild.clickable.keyboardEnabled) (button (Just "Launch")) <| do
packing.expands =- Fitting
let spawnChild = mdo
h <- getDynamic addressBar label
is <- getDynamic instanceChoice alternatives
s' <- getDynamic instanceChoice selected
let i = fromMaybe "" (zip [0..] is^.at s')
tc@(prog,args) = ("/usr/bin/curly",["--at",h+"/"+i,"--interactive"])
deleteTab = delTab (hd,t)
t <- switch3 . U3_1 =<< terminal <| do terminalStatus =- CommandTerminal tc
onHigh (terminalStatus.sat (==IdleTerminal)) $ \_ -> deleteTab
hd <- notebookLabel deleteTab ("Session:"+h+"/"+i)
runDynamicState display $ do children =~ (+[(hd,t)])
onHigh clicked $ \_ -> spawnChild
libsButton <- (boxChild.clickable.keyboardEnabled) (button (Just "Libraries")) <| do
packing.expands =- Fitting
let spawnChild = mdo
let deleteTab = delTab (hd,c)
libs <- availableLibs
labels <- for libs $ \(lid,meta) -> do
let s = fromMaybe "" (meta^?at "synopsis".t'Just.t'Pure)
def <- switch2 . Left =<< text "Loading..."
boxChild (expander (show lid+": "+s) def) <*= \e -> runDynamicState e $ do
packing.expands =- Fitting
onHigh (expanded.sat id) $ \_ -> do
case findLib lid of
Just l -> setDynamic def traitValue . Right =<< contextW (l^.flLibrary.exports) showLeafDoc
Nothing -> putStrLn $ "Couldn't find library "+show lid
c <- switch3 . U3_2 =<< textFrame "Libraries in repositories" =<< boxN Vertical labels
hd <- notebookLabel deleteTab "All Libraries"
runDynamicState display $ do children =~ (+[(hd,c)])
onHigh clicked $ \_ -> spawnChild
sep <- boxChild (separator Vertical) <| do packing.expands =- Fitting
display <- boxChild notebook
bar <- (boxChild.mkMenuBar) [subMenu "File" [accelMenuItem "Close tab" <| do shortcuts =- Just "Delete current tab"
,accelMenuItem "Open file..." <| do shortcuts =- Just "Open file"
,accelMenuItem "Manage repositories..." <| do shortcuts =- Just "Manage repositories"
,accelMenuItem "Quit" <| do shortcuts =- Just "Quit"]]
runDynamicState bar (packing.expands =- Fitting)
actionFrame <- boxChild (textFrame "Actions" =<< box2 Horizontal launchButton libsButton) <| do packing.expands =- Fitting
packing.padding =- 4
addressFrame <- boxChild (textFrame "Address" =<< box2 Horizontal addressBar instanceChoice)
top <- boxChild (box2 Horizontal addressFrame actionFrame) <| do packing.expands =- Fitting
contents <- box4 Vertical bar top sep display
win <- window "The Curly GUI" contents
fchoose <- fileChooser (const (const True))
fcDialog <- mfix $ \fcDialog -> do
let openSelected = do
sel <- getDynamic fchoose selected
withCurlyConfig (map Left sel) $ withCurlyPlex ?curlyConfig $ withMountain $ mdo
w <- switch3 . U3_3 =<< contextW localContext showLeafDoc
hd <- notebookLabel (delTab (hd,w)) ("Context:"+head sel)
addTab (hd,w)
hideDialog = setDynamic fcDialog visible False
runDynamicState fchoose $ do
onChange lastActivation $ \_ _ -> openSelected >> hideDialog
dialog win "Open file" [("Open",True),("Cancel",False)] fchoose <| do
onChange lastActivation $ \_ (_,res) -> when res openSelected >> hideDialog
repoDialog <- mdo
ks <- getKeyStore
keyId <- (boxChild.clickable.keyboardEnabled) (comboBox (keys ks)) <| do
packing.expands =- Floating
onChange selected $ \_ sel -> do
key <- (!!sel) <$> getDynamic keyId alternatives
StampedBranches _ bs <- getVCSBranches key
setDynamic branchName alternatives (keys bs)
branchName <- (boxChild.clickable.keyboardEnabled) (comboBox []) <| do packing.expands =- Fitting
ret <- window "Manage repositories" =<< textFrame "VC repository" =<< box2 Horizontal keyId branchName
return ret <| do visible =- False
return ()
i'Free :: (Widget (f (FreeW f a)):+:Widget a) :<->: FreeW f a
i'Free = iso (Join . Compose . Compose <|> Pure)
(\x -> case x of
Join (Compose (Compose x)) -> Left x
Pure x -> Right x)
type FreeW f a = Free (Dynamic:.:WProps:.:f) (Widget a)
freeW :: FreeW f a -> IO (Widget (FreeW f a))
freeW f = isoTrait (from (mapping i'Free)) (switch2 (f^..i'Free))
newtype CWNode a = CWNode (Box (SubWidget Separator,SubWidget (HList (Expander a))))
contextW :: Context -> (LeafExpr GlobalID -> IO ()) -> IO (Widget (FreeW CWNode (Box (SubWidget Separator,SubWidget Button))))
contextW (Pure (s,e)) expr = freeW . Pure =<< do
t <- boxChild (button (Just (pretty s))) <| do
packing.expands =- Fitting
onChange lastActivation $ \_ _ -> print "Clicked" >> expr e
sep <- boxChild (separator Vertical) <| do packing =~ set expands Fitting . set padding 15
box2 Horizontal sep t
contextW (Join (ModDir l)) k = do
subs <- for l $ \(s,a) -> boxChild (expander s =<< contextW a k) <| do packing.expands =- Fitting
sep <- boxChild (separator Vertical) <| do packing.expands =- Fitting; packing.padding =- 15
c <- boxChild (boxN Vertical subs)
e <- isoTrait (mapping (iso (\(CWNode x) -> x) CWNode)) (box2 Horizontal sep c)
freeW (Join (Compose $ Compose e))
lastClickOrKey :: (DynamicProperty w ClickMap LastClicksProp
,DynamicProperty w KeyMap LastKeysProp) => [KeyCode] -> FixFold' w (Seconds,ClickType)
lastClickOrKey ks cc w = w <$ cc (ktm,kt)
where (ktm,kt) = foldl' max (zero,Released) $
[w^.lastKeys.at k.l'Just (zero :: Seconds,Released) | k <- ks]
+ [(tm,t) | (_,(tm,t,_,_)) <- w^.lastClicks.ascList]
clicked :: (DynamicProperty w ClickMap LastClicksProp
,DynamicProperty w KeyMap LastKeysProp) => FixFold' w Seconds
clicked = lastClickOrKey [GDK_KEY_Return,GDK_KEY_space].sat (\(_,x) -> x==Released).l'1
subMenu n l = do
c <- menu =<< sequence l
accelMenuItem n <| (children =- Just c)
mkMenuBar lm = menuBar =<< sequence lm
module Curly.GUI2 where
import Definitive
import Graphics.Widget
import Graphics.Widget.GL.Scene
import Graphics.Widget.GL.Vertex
main = runApplication $ mdo
b <- clickable (button (Just "Open")) <| do
onHigh (lastClick 1.sat ((==Pressed) . by l'2)) $ \_ -> mdo
fc <- fileChooser (const (pure True)) <| do
onChange lastActivation $ \_ _ -> do
setDynamic w visible False
l <- getDynamic fc selected
print l
w <- dialog win "Open file..." [("Open",True),("Cancel",False)] fc
setDynamic w visible True
win <- window "Test window" b <| do visible =- True
return ()
#!/bin/sh
install_curly() {
curly --goody install.sh | sh -s "$@"
case "$1" in
bash-completions)
source "$HOME/.local/share/bashcomps/bashcomps.shl"
;;
esac
}
No preview for this file type
......@@ -27,6 +27,6 @@ the heights of getting to compile this fine compiler, by running the
following commands :
~~~{.terminal}
git clone http://git.curly-lang.org/marc/curly
git clone http://git.curly-lang.org/marc/stack-libs
cd curly && stack build
~~~~
% The Curly FAQ
% Marc Coiffier
#!/bin/sh
curly_version="0.59.4.4"
curly_version="0.59.4.5"
curly_url="https://www.curly-lang.org/pkg/curly-$curly_version.tar.xz"
import_stdkeys=
......
......@@ -4,7 +4,7 @@ module Main(
main,
-- * Functions for running your own Curly instances
initCurly,runTargets,
runTargets,
) where
import Control.Concurrent (forkIO,forkFinally)
......@@ -38,7 +38,7 @@ import System.FilePath.Posix (splitFileName)
main :: IO ()
main = cli "curly" $ do
initCurly
initCurly getDataFileName
cwd <- getCurrentDirectory
let prefixes "" = []
......@@ -76,11 +76,6 @@ data TargetType = ForkTgt (MVar ())
t'IOTgt :: Traversal' TargetType (IO ())
t'IOTgt k (IOTgt m) = IOTgt<$>k m
t'IOTgt _ x = return x
initCurly = do
setLocaleEncoding utf8
putMVar getDataFileName_ref getDataFileName
curlyDataFileName "proto/vc" >>= \p -> modifyIORef vcsProtoRoots (p:)
ioTgt = return . IOTgt
forkTgt m = do
......
{-# LANGUAGE ViewPatterns,TypeFamilies #-}
module Curly.UI(
-- * Variables
curlyPort,curlyHistoryFile,
curlyPort,curlyHistoryFile,curlyDataFileName,
-- * Arguments
-- * Initialization and arguments
initCurly,
CurlyConfig,
parseCurlyArgs,withCurlyPlex,withCurlyConfig,
curlyFiles,
......@@ -12,7 +13,7 @@ module Curly.UI(
withMountain,reloadMountain,sourceFile,
-- * Misc
watchSources,sourceLibs,getVCSBranches,curlyDataFileName,getDataFileName_ref
watchSources,sourceLibs,getVCSBranches,
) where
import Control.Concurrent.MVar
......@@ -30,13 +31,14 @@ import Curly.Core.VCS
import Curly.UI.Options
import Data.IORef
import Data.List (sortBy)
import GHC.IO.Encoding (utf8,setLocaleEncoding)
import IO.Filesystem hiding ((</>))
import IO.Time
import Language.Format
import Language.Syntax.CmdArgs hiding (hspace)
import System.Environment (getExecutablePath)
import System.IO (IOMode(..),withFile)
import System.Posix.Files (createSymbolicLink,removeLink,fileAccess)
import System.Environment (getExecutablePath)
withMountain :: (?curlyPlex :: CurlyPlex,MonadIO m) => ((?mountain :: Mountain) => m a) -> m a
withMountain m = liftIO (trylogLevel Quiet (return undefined) $ readIORef (?curlyPlex^.mountainCache)) >>= \(c,_) -> let ?mountain = c in m
......@@ -233,6 +235,11 @@ curlyDataFileName n = withMVar getDataFileName_ref $ \gdfn -> do
if canRead then return f
else k
initCurly gdf = do
setLocaleEncoding utf8
putMVar getDataFileName_ref gdf
curlyDataFileName "proto/vc" >>= \p -> modifyIORef vcsProtoRoots (p:)
i'isJust :: Monoid m => Iso' (Maybe m) Bool
i'isJust = iso (maybe False (const True)) (\b -> if b then Just zero else Nothing)
......
......@@ -64,7 +64,7 @@ instance Functor m => StateRes (StateT s m a) (s -> m s) (s -> m a) where
state :: Iso (State s a) (State t b) (s -> (s,a)) (t -> (t,b))
state = mapping i'Id.stateT
(=-) :: MonadState s m => Fold' s s' -> s' -> m ()
(=-) :: MonadState s m => FixFold' s s' -> s' -> m ()
infixl 1 =-,=~,<~
(<~) :: MonadState s m => Lens' s a -> (a -> (a,b)) -> m b
(<~) l st = getl l >>= \a -> let (a',b) = st a in b <$ modify (l %- a')
......@@ -72,7 +72,7 @@ swapWith :: MonadState s m => Lens' s a -> (a -> a) -> m a
swapWith l f = l <~ \a' -> (f a',a')
l =- x = modify (set l x)
(=~) :: MonadState s m => Fold' s a -> (a -> a) -> m ()
(=~) :: MonadState s m => FixFold' s a -> (a -> a) -> m ()
l =~ f = modify (warp l f)
(^>=) :: MonadState s m => LensLike m a a s s -> (a -> m ()) -> m ()
l ^>= k = get >>= \s -> forl_ l s k
......
# Revision history for definitive-graphics
## 2.2.0.1 -- YYYY-mm-dd
* First version. Released on an unsuspecting world.
This library is great !
http://coiffier.net/projects/definitive-framework.html
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment