filepicker/test.icl

   1 module test
   2
   3 from iTasks.UI.Editor.Controls import :: ChoiceNode{..}
   4 import StdEnv
   5 import Data.List
   6 import Data.Func
   7 import Data.Functor
   8 import Data.Tuple
   9 import Data.Tree
  10 import Data.Maybe
  11 import Data.Error
  12 import Control.Applicative
  13 import Control.Monad
  14 import Control.Monad.State
  15 import Control.Monad.Identity
  16 import System.FilePath
  17 import System.File
  18 import System.Directory
  19
  20 import Text.GenPrint
  21 import iTasks => qualified >>=, >>|, forever, sequence, return
  22
  23 derive class iTask RTree, ChoiceNode
  24
  25 Start w = startEngine (selectFile "/opt/clean/lib/StdLib" () False) w
  26
  27 selectFile :: FilePath d Bool -> Task [FilePath] | toPrompt d
  28 selectFile root p m = tbind
  29         (accWorldOSError (appFst (fmap numberTree) o recurseDirectory root ""))
  30         \tree->editSelection p m (SelectInTree (pure o toChoiceNode fp2cn) fromTree) tree []
  31 where
  32         numberTree :: ((RTree a) -> RTree (Int, a))
  33         numberTree = flip evalState zero o foldTree \a cs->
  34                 (\lvs i->RNode (i, a) lvs) <$> sequence cs <*> getState <* modify ((+)one)
  35
  36         toChoiceNode :: (Int a -> ChoiceNode) -> ((RTree (Int, a)) -> ChoiceNode)
  37         toChoiceNode tfun = foldTree \a cs->{ChoiceNode | uncurry tfun a & children=cs}
  38
  39         fp2cn :: Int (FilePath, Bool) -> ChoiceNode
  40         fp2cn i (fp, bool) = {id =if bool (~i) i,label=dropDirectory fp,icon=Nothing,expanded=False,children=[]}
  41
  42         fromTree :: (RTree (Int, (FilePath, Bool))) [Int] -> [FilePath]
  43         fromTree tree sel = [f\\(i, (f, _))<-leafs tree | isMember i sel]
  44
  45 recurseDirectory :: !FilePath !FilePath !*World -> *(MaybeOSError (RTree (FilePath, Bool)), !*World)
  46 recurseDirectory acc fp w
  47         # fp = acc </> fp
  48         # (mfi, w) = getFileInfo fp w
  49         | isError mfi = (liftError mfi, w)
  50         # (Ok fi) = mfi
  51         | not fi.directory = (Ok $ RNode (fp, False) [], w)
  52         # (mcs, w) = readDirectory fp w
  53         | isError mfi = (liftError mcs, w)
  54         # (cs, w) = appFst sequence $ mapSt (recurseDirectory fp) (filter (\c->not (elem c [".", ".."])) (fromOk mcs)) w
  55         = (RNode (fp, True) <$> cs, w)