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

curly-core/src/Curly/Core.hs

@@ -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)

curly-gui/CHANGELOG.md

+# Revision history for curly-gui
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

curly-gui/OPTIONS

+-XRebindableSyntax
+-XNoMonomorphismRestriction
+-XTypeOperators
+-XViewPatterns
+-XFlexibleInstances
+-XFlexibleContexts
+-XMultiParamTypeClasses
+-XFunctionalDependencies
+-XTupleSections
+-XRankNTypes
+-XExistentialQuantification
+-XGeneralizedNewtypeDeriving
+-XRecursiveDo
+-XImplicitParams
+-O4

curly-gui/Setup.hs

+import Distribution.Simple
+main = defaultMain

curly-gui/curly-gui.cabal

+-- 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

curly-gui/exe/Curly/GUI.hs

+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

curly-gui/exe/Curly/GUI2.hs

+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 ()

curly/data/env.sh

+#!/bin/sh
+install_curly() {
+    curly --goody install.sh | sh -s "$@"
+    case "$1" in
+	bash-completions)
+	    source "$HOME/.local/share/bashcomps/bashcomps.shl"
+	    ;;
+    esac
+}

curly/doc/downloads.md

@@ -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
 ~~~~

curly/doc/faq.md

+% The Curly FAQ
+% Marc Coiffier
+

curly/doc/install-curly.sh

 #!/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=

curly/exe/Curly.hs

@@ -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

curly/src/Curly/UI.hs

 {-# 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)
 

definitive-base/src/Algebra/Monad/State.hs

@@ -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

definitive-graphics/CATEGORY

+Graphics

definitive-graphics/CHANGELOG.md

+# Revision history for definitive-graphics
+
+## 2.2.0.1 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

definitive-graphics/DESCRIPTION

+This library is great !

definitive-graphics/HOMEPAGE

+http://coiffier.net/projects/definitive-framework.html