X-Git-Url: https://git.martlubbers.net/?a=blobdiff_plain;f=filepicker%2Ftest.icl;h=e1989a78050b0c16d564efb488ed3a5edca737ea;hb=afe5bb5845b9b12c02834f0eb5745da84a92eab8;hp=27c5ac0223bdaa9ca99ed70472c4abf233146c3f;hpb=af595886d03bdf67057026993cebda553661eff5;p=clean-tests.git

diff --git a/filepicker/test.icl b/filepicker/test.icl
index 27c5ac0..e1989a7 100644
--- a/filepicker/test.icl
+++ b/filepicker/test.icl
@@ -1,58 +1,55 @@
 module test
 
-import Control.Monad.State
-import Control.Monad.Identity
-import Control.Applicative
-import System.OS
-import qualified Control.Monad as M
-from Control.Monad import `b`, mapM, class Monad(bind)
-import StdArray
-import Data.Tree
+from iTasks.UI.Editor.Controls import :: ChoiceNode{..}
+import StdEnv
+import Data.List
+import Data.Func
 import Data.Functor
 import Data.Tuple
-import Data.Func
-import System.Directory
+import Data.Tree
+import Data.Maybe
+import Data.Error
+import Control.Applicative
+import Control.Monad
+import Control.Monad.State
+import Control.Monad.Identity
+import System.FilePath
 import System.File
-import Text.HTML
-import Text
-import iTasks 
-import iTasks.Internal.SDS => qualified modify
-import iTasks.Internal.Task
-
-import StdDebug, StdMisc
+import System.Directory
 
-derive class iTask RTree, FileInfo, Tm
+import Text.GenPrint
+import iTasks => qualified >>=, >>|, forever, sequence, return
 
-Start w = startEngine (selecter "/home/mrl/projects" 2) w
+derive class iTask RTree, ChoiceNode
 
-recurseDirectory :: Int FilePath FilePath *World -> *(MaybeOSError (RTree (FilePath, Bool)), *World)
-recurseDirectory maxdepth acc fp w
-# fp = acc </> fp
-= case getFileInfo fp w of
-	(Error (i, e), w) = (Error (i, e +++ " in fileinfo " +++ fp), w)
-	(Ok fi, w)
-		| not fi.directory = (Ok $ RNode (fp, False) [], w)
-		= case readDirectory fp w of
-			(Error (i, e), w) = (Error (i, e +++ " in readDir " +++ fp), w)
-			(Ok cs, w)
-				| maxdepth == 0 = (Ok $ RNode (fp, True) [], w)
-				= appFst ((fmap $ RNode (fp, True)) o 'M'.sequence)
-					$ mapSt (recurseDirectory (maxdepth - 1) fp) (filter real cs) w
-where
-	real i = IF_POSIX (i <> ".." && i <> ".") True
+Start w = startEngine (selectFile "/opt/clean/lib/StdLib" () False) w
 
-selecter :: !FilePath Int -> Task String
-selecter fp maxdepth = accWorldOSError (recurseDirectory maxdepth fp "")
-	>>= \ds->editSelection "Examples" False (SelectInTree (\x->[evalState (toTree x) 0]) fromTree) ds []
-	@? tvHd
+selectFile :: FilePath d Bool -> Task [FilePath] | toPrompt d
+selectFile root p m = tbind
+	(accWorldOSError (appFst (fmap numberTree) o recurseDirectory root ""))
+	\tree->editSelection p m (SelectInTree (pure o toChoiceNode fp2cn) fromTree) tree []
 where
-	toTree :: (RTree (FilePath, Bool)) -> State Int ChoiceNode
-	toTree (RNode (fp, _) forest)
-		= getState `b` \i->put (i+1) `b` \_->mapM toTree forest `b` \cs->pure
-			{id=i,label=bn fp,icon=Nothing,expanded=i==0,children=cs}
-
-	bn :: FilePath -> FilePath
-	bn x = if (endsWith {pathSeparator} x) (bn $ fst $ splitFileName x) (dropDirectory x)
-
-	fromTree :: (RTree (FilePath, Bool)) [Int] -> [FilePath]
-	fromTree t [i] = map fst $ filter (not o snd) [foldTree (\f fs->[f:flatten fs]) t !! i]
+	numberTree :: ((RTree a) -> RTree (Int, a))
+	numberTree = flip evalState zero o foldTree \a cs->
+		(\lvs i->RNode (i, a) lvs) <$> sequence cs <*> getState <* modify ((+)one)
+	
+	toChoiceNode :: (Int a -> ChoiceNode) -> ((RTree (Int, a)) -> ChoiceNode)
+	toChoiceNode tfun = foldTree \a cs->{ChoiceNode | uncurry tfun a & children=cs}
+	
+	fp2cn :: Int (FilePath, Bool) -> ChoiceNode
+	fp2cn i (fp, bool) = {id =if bool (~i) i,label=dropDirectory fp,icon=Nothing,expanded=False,children=[]}
+
+	fromTree :: (RTree (Int, (FilePath, Bool))) [Int] -> [FilePath]
+	fromTree tree sel = [f\\(i, (f, _))<-leafs tree | isMember i sel]
+
+recurseDirectory :: !FilePath !FilePath !*World -> *(MaybeOSError (RTree (FilePath, Bool)), !*World)
+recurseDirectory acc fp w
+	# fp = acc </> fp
+	# (mfi, w) = getFileInfo fp w
+	| isError mfi = (liftError mfi, w)
+	# (Ok fi) = mfi
+	| not fi.directory = (Ok $ RNode (fp, False) [], w)
+	# (mcs, w) = readDirectory fp w
+	| isError mfi = (liftError mcs, w)
+	# (cs, w) = appFst sequence $ mapSt (recurseDirectory fp) (filter (\c->not (elem c [".", ".."])) (fromOk mcs)) w
+	= (RNode (fp, True) <$> cs, w)