implementation module iTasks.Gin.Storage from StdFunc import o, seqList, ::St import StdMisc, StdClass, StdList, StdOrdList, StdChar, StdString, StdFile from System.File import qualified fileExists, readFile from System.FilePath import addExtension, dropExtension, takeExtension, :: FilePath, import qualified System.FilePath from Text import class Text (..), instance Text String from System.Directory import readDirectory //import Directory //import Text from Text.JSON import fromJSON, instance fromString JSONNode import System.OSError import Data.Void from iTasks import class iTask, enterChoice, >>*, >>|, >>=, :: Task, :: ChoiceOption (..), :: EnterOption (..), :: ViewOption (..), :: ActionOption (..), exportJSONFile from iTasks import class descr (..), instance descr String, class OptionContainer (..), instance OptionContainer [], return, enterInformation, viewInformation, :: Stability (..), exportTextFile, accWorld, accWorldOSError from iTasks import ActionNo, Always, ActionYes, :: TaskStep (..), :: Action (..), :: Hotkey (..), :: Key (..), :: ActionName (..), :: TaskValue (..), :: ChoiceType (..) from iTasks import :: Tree, :: MultiChoiceType, :: UIControlSequence, class Functor, instance Functor [] import iTasks.Gin.Config import iTasks.Gin.Syntax import iTasks.Gin.Parser import iTasks.Gin.Printer import iTasks.Gin.FlowLibrary import iTasks.Gin.DCLImport GRAPHICAL_EXTENSION :== "gcl" DEFINITION_EXTENSION :== "dcl" IMPLEMENTATION_EXTENSION :== "icl" derive class iTask MaybeError listDirectory :: !String !String !*World -> (MaybeOSError [String], *World) listDirectory path extension world # (res, world) = readDirectory path world | isError res = (res, world) = (Ok [ dropExtension m \\ m <- (fromOk res) | toLowerCase (takeExtension m) == extension ], world) listModules :: !GinConfig !*World -> (MaybeOSError [String], *World) listModules config world = listDirectory config.userPath GRAPHICAL_EXTENSION world searchPathModules :: !GinConfig !*World -> ([String], *World) searchPathModules config world # (res, world) = listDirectory config.userPath GRAPHICAL_EXTENSION world | isError res = ([], world) # userModules = fromOk res # (searchPathModules, world) = sp config.searchPaths world = (sort searchPathModules ++ sort userModules, world) where sp :: [String] *World -> ([String], *World) sp [] world = ([], world) sp [path:paths] world # (mFiles, world) = listDirectory path DEFINITION_EXTENSION world | isError mFiles = sp paths world # (files`, world) = sp paths world = (fromOk mFiles ++ files`, world) modulePath :: !GinConfig !String !*World -> (Maybe String, *World) modulePath config name world = mp [config.userPath : config.searchPaths] world where mp :: [String] *World -> (Maybe String, *World) mp [] world = (Nothing, world) mp [path:paths] world # filepath = (addExtension (path name) GRAPHICAL_EXTENSION) # (exists, world) = 'System.File'.fileExists filepath world | exists = (Just filepath, world) # filepath = (addExtension (path name) DEFINITION_EXTENSION) # (exists, world) = 'System.File'.fileExists filepath world | exists = (Just filepath, world) = mp paths world readModule :: !GinConfig !String !*World -> (MaybeErrorString GModule, *World) readModule config name world # (mPath, world) = modulePath config name world | isNothing mPath = (Error ("Module " +++ name +++ " not found in search path"), world) # path = fromJust mPath # (res, world) = 'System.File'.readFile path world | isError res = (Error ("Failed to read file " +++ fromJust mPath), world) # contents = fromOk res = case toLowerCase (takeExtension path) of GRAPHICAL_EXTENSION = case readJSON contents of Nothing = (Error ("Failed to parse file " +++ fromJust mPath), world) Just json = (Ok json, world) DEFINITION_EXTENSION = importDCL path contents world where readJSON :: !String -> Maybe GModule readJSON s = fromJSON (fromString s) readModules :: !GinConfig ![String] !*World -> (MaybeErrorString [GModule], *World) readModules config [] world = (Ok [], world) readModules config [name:names] world # (mMod, world) = readModule config name world | isError mMod = (liftError mMod, world) # (mMods, world) = readModules config names world | isError mMods = (mMods, world) = (Ok [fromOk mMod : fromOk mMods], world) importModules :: !GinConfig ![String] !*World -> (MaybeErrorString [GModule], *World) importModules config [] world = (Ok [predefinedModule], world) importModules config names world # (mMods, world) = readModules config names world | isError mMods = (mMods, world) = (Ok [predefinedModule : fromOk mMods], world) writeModule :: !GinConfig !String !GModule -> Task Void writeModule config name gMod # basename = (config.userPath name) # gMod = { GModule | gMod & name = name } = exportJSONFile (addExtension basename GRAPHICAL_EXTENSION) gMod >>| accWorld (gToAModule gMod config) >>= \st -> case runParse st of GSuccess aMod = exportTextFile (addExtension basename DEFINITION_EXTENSION) (prettyPrintAModule PODCL aMod) >>| exportTextFile (addExtension basename IMPLEMENTATION_EXTENSION) (prettyPrintAModule POICL aMod) >>| return Void GError errors = return Void moduleExists :: !GinConfig !String -> Task Bool moduleExists config name = accWorld (modulePath config name) >>= \path -> return (isJust path) newModuleName :: !GinConfig -> Task String newModuleName config = enterInformation "Give name of new module:" [] >>= \name -> moduleExists config name >>= \exists -> if exists ( viewInformation ("Module " +++ name +++ " already exists, do you want to overwrite?") [] Void >>* [ Always ActionYes (return name) , Always ActionNo (newModuleName config)] ) ( return name ) chooseModule :: !GinConfig -> Task (Maybe (!String, !GModule)) chooseModule config = accWorldOSError (listModules config) >>= \all -> case all of [] -> viewInformation "Choose module" [] "No modules stored !" >>| return Nothing names -> enterChoice "Choose module you want to use:" [] names >>= \choice -> accWorld (readModule config choice) >>= \mg -> case mg of Error e = viewInformation "Error" [] ("Failed to read module " +++ choice +++ ":" +++ e) >>| return Nothing Ok gMod = return (Just (choice, gMod))