diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/billeksah-services.cabal b/billeksah-services.cabal new file mode 100644 --- /dev/null +++ b/billeksah-services.cabal @@ -0,0 +1,43 @@ +name: billeksah-services +version: 1.0.0 +cabal-version: >= 1.8 +build-type: Simple +license: LGPL +license-file: LICENSE +copyright: Juergen "jutaro" Nicklisch-Franken +maintainer: maintainer@leksah.org +homepage: http://www.leksah.org +package-url: https://github.com/leksah +bug-reports: http://code.google.com/p/leksah/issues/list +synopsis: Leksah library +description: General library used by leksah +category: Control +author: Juergen "jutaro" Nicklisch-Franken +tested-with: GHC ==7.0 + +Library + exposed-modules: + Base + Base.Event + Base.ConfigFile + Base.Graph + Base.PluginTypes + Base.MyMissing + Base.State + Base.Config + Base.Selector + exposed: True + buildable: True + extensions: CPP + hs-source-dirs: src + build-depends: + base >=4.0.0.0 && <4.4, + containers >=0.2 && <0.5, + mtl >=1.1.0.2 && <2.1, + transformers >= 0.2.2.0 && < 0.3, + parsec >= 3.1.1 && < 4, + pretty >=1.0.1.0 && <1.1, + directory >= 1.1.0.0 && <1.2, + filepath >= 1.2.0.0 && < 1.3 + + diff --git a/src/Base.hs b/src/Base.hs new file mode 100644 --- /dev/null +++ b/src/Base.hs @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- +-- Module : Base +-- Copyright : Juergen Nicklisch-Franken +-- License : LGPL +-- +-- Maintainer : maintainer@leksah.org +-- Stability : provisional +-- Portability : portabel +-- +-- | Export of billeksah base services +-- +----------------------------------------------------------------------------- + +module Base ( + module Base.Config, + module Base.Event, + module Base.Graph, + module Base.MyMissing, + module Base.PluginTypes, + module Base.ConfigFile, + module Base.State, + module Base.Selector +) where + +import Base.Config +import Base.Event +import Base.Graph +import Base.MyMissing +import Base.PluginTypes +import Base.ConfigFile +import Base.State +import Base.Selector diff --git a/src/Base/Config.hs b/src/Base/Config.hs new file mode 100644 --- /dev/null +++ b/src/Base/Config.hs @@ -0,0 +1,264 @@ +----------------------------------------------------------------------------- +-- +-- Module : Base.Config +-- Copyright : Juergen Nicklisch-Franken +-- License : LGPL +-- +-- Maintainer : maintainer@leksah.org +-- Stability : provisional +-- Portability : portabel +-- +-- | Plugin Configurations +-- +----------------------------------------------------------------------------- + +module Base.Config ( + loadPluginDescr, + loadPluginDescription, + writePluginDescr, + loadPluginConfig, + writePluginConfig, + + loadListFromConfig, + + allKnownPlugins, + getPrereqChoices, + + defaultConfig, + defaultPlugin + +) where + +import Base.PluginTypes +import Base.ConfigFile +import Base.Event +import Base.State + +import qualified Text.PrettyPrint as PP (text) +import Control.Monad (foldM, filterM, unless) +import Data.Version (showVersion, parseVersion, Version(..)) +import Data.List (nubBy, intersperse, isPrefixOf) +import System.Directory (doesFileExist, getDirectoryContents) +import System.FilePath + (dropFileName, (), dropExtension, takeExtension, takeFileName) +import Text.ParserCombinators.ReadP (readP_to_S) +import Data.Maybe (mapMaybe) +import qualified Data.Map as Map + (elems, toList, lookup, member, insert, empty) +import Data.Map (Map) +import Base.Graph (topSortGraph) +import Base.State (StateM) +import Control.Monad.IO.Class (MonadIO(..)) + +-- | Plugin file (.lksp) + +defaultPlugin = Plugin { + plName = "", + plVersion = Version[][], + plModule = "", + plInterface = "", + plPrerequisites = [], + plChoices = [], + plSynopsis = ""} + +pluginDescr :: [FieldDescriptionS Plugin] +pluginDescr = [ + mkFieldS + "Name of the plugin" + Nothing + stringPrinter + stringParser + plName + (\ b a -> a{plName = b}) + , mkFieldS + "Version" + Nothing + (stringPrinter . showVersion) + versionParser + plVersion + (\ b a -> a{plVersion = b}) + , mkFieldS + "Module" + Nothing + stringPrinter + stringParser + plModule + (\ b a -> a{plModule = b}) + , mkFieldS + "Interface" + Nothing + stringPrinter + stringParser + plInterface + (\ b a -> a{plInterface = b}) + , mkFieldS + "Prerequisite list" + Nothing + (stringPrinter . showPluginList) + parsePluginList + plPrerequisites + (\ b a -> a{plPrerequisites = b}) + , mkFieldS + "Synopsis" + (Just "or call it comment") + stringPrinter + stringParser + plSynopsis + (\ b a -> a{plSynopsis = b}) + ] + +loadPluginDescr :: FilePath -> IO Plugin +loadPluginDescr fn = readFieldsSimple fn pluginDescr defaultPlugin + +writePluginDescr :: FilePath -> Plugin -> IO () +writePluginDescr fpath descr = do + exists <- doesFileExist fpath + if exists + then do + descrOld <- loadPluginDescr fpath + unless (descrOld == descr) $ + writeFile fpath (showFieldsSimple descr pluginDescr) + else writeFile fpath (showFieldsSimple descr pluginDescr) + +-- | Plugin configfile (.lkshc) + +defaultConfig = PluginConfig { + cfName = "Unnamed zombie", + cfVersion = Version[0][], + cfPlugins = [], + cfChoices = [], + cfSynopsis = ""} + + +pluginConf :: [FieldDescriptionS PluginConfig] +pluginConf = [ + mkFieldS + "Name of the config" + Nothing + stringPrinter + stringParser + cfName + (\ b a -> a{cfName = b}) + , mkFieldS + "Version" + Nothing + (stringPrinter . showVersion) + versionParser + cfVersion + (\ b a -> a{cfVersion = b}) + , mkFieldS + "Plugin list" + Nothing + (stringPrinter . showPluginList) + parsePluginList + cfPlugins + (\ b a -> a{cfPlugins = b}) + , mkFieldS + "Synopsis" + (Just "or call it comment") + stringPrinter + stringParser + cfSynopsis + (\ b a -> a{cfSynopsis = b}) + ] + +loadPluginConfig :: FilePath -> IO PluginConfig +loadPluginConfig fn = readFieldsSimple fn pluginConf defaultConfig + +writePluginConfig :: FilePath -> PluginConfig -> IO () +writePluginConfig fpath config = do + configOld <- loadPluginConfig fpath + unless (configOld == config) $ + writeFile fpath (showFieldsSimple config pluginConf) + +type Error = String + +loadPluginDescription :: FilePath -> (PluginName, VersionBounds) -> IO (Either Plugin Error) +loadPluginDescription fp (name,bounds) = do + versions <- getPluginVersions fp name + case selectOptimalVersion versions bounds of + Nothing -> return (Right ("Can't select version for plugin: " ++ name)) + Just v -> getPluginDescr fp name v >>= \ p -> return (Left p) + +-- | Returns the description of a plugin +getPluginDescr :: FilePath -> String -> Version -> IO Plugin +getPluginDescr fp name version = loadPluginDescr + (fp name ++ "-" ++ showVersion version ++ ".lkshp") + +-- | Take the latest allowed +selectOptimalVersion :: [Version] -> VersionBounds -> Maybe Version +selectOptimalVersion [] _ = Nothing +selectOptimalVersion versions (Nothing,Nothing) = Just $ maximum versions +selectOptimalVersion versions (Just vl,Nothing) = case [ v | v <- versions, v >= vl] of + [] -> Nothing + l -> Just $ maximum l +selectOptimalVersion versions (Nothing,Just vu) = case [ v | v <- versions, v <= vu] of + [] -> Nothing + l -> Just $ maximum l +selectOptimalVersion versions (Just vl,Just vu) = case [ v | v <- versions, v >= vl && v <= vu] of + [] -> Nothing + l -> Just $ maximum l + +-- | Returns a list of versions +getPluginVersions :: FilePath -> String -> IO [Version] +getPluginVersions fp name = catch (do + filesAndDirs <- getDirectoryContents fp + files <- filterM (\f -> doesFileExist (fp f)) filesAndDirs + let relevantFiles = [ nameWithVersion | nameWithVersion <- files, + isPrefixOf name nameWithVersion, + takeExtension nameWithVersion == ".lkshp"] + + return (mapMaybe (\ f -> + case filter (\r -> snd r == "") ((readP_to_S parseVersion) (extractVersion f)) of + (a,_):_ -> Just a + [] -> Nothing) relevantFiles)) + (\e -> do +-- putStrLn "Config>>getPluginVersions: ++ show e" + return []) + where + extractVersion string = drop (length name + 1) (dropExtension string) + +-- | First collect all Plugins, then make them a graph and topsort it +loadListFromConfig :: BaseEvent -> FilePath -> PluginConfig -> StateM [Plugin] +loadListFromConfig baseEvent fp PluginConfig{cfPlugins = prerequ} = do + collectedPlugins <- foldM loadDeep Map.empty prerequ + let pluginGraph = foldr (buildGraph collectedPlugins) Map.empty (Map.elems collectedPlugins) + return (reverse (topSortGraph pluginGraph)) + where + loadDeep :: Map String Plugin -> Prerequisite -> StateM (Map String Plugin) + loadDeep map prerequ@(name,version) | Map.member name map = return map + | otherwise = do + res <- liftIO $ loadPluginDescription fp prerequ + case res of + Left plugin -> do + let map2 = Map.insert name plugin map + foldM loadDeep map2 (plPrerequisites plugin) + Right error -> do + message Error ("Can't load plugin descr " ++ show prerequ ++ " " ++ error) + return map + buildGraph allPlugs plug graph = + Map.insert plug + (mapMaybe (\ (name,_) -> Map.lookup name allPlugs) (plPrerequisites plug)) graph + +allKnownPlugins :: FilePath -> IO [Plugin] +allKnownPlugins fp = do + filesAndDirs <- getDirectoryContents fp + files <- filterM (\f -> doesFileExist (fp f)) filesAndDirs + let relevantFiles = [ fp | fp <- files, takeExtension fp == ".lkshp"] + mapM (\ fp -> loadPluginDescr fp) relevantFiles + +getPrereqChoices :: FilePath -> IO [Prerequisite] +getPrereqChoices currentConfigPath= do + possiblePlugins <- allKnownPlugins (dropFileName currentConfigPath) + let possibleBounds = map getStandardBounds possiblePlugins + let possibleChoices = nubBy (\e1 e2 -> fst e1 == fst e2) $ + [ e | e@(n,_) <- possibleBounds] + return possibleChoices + +getStandardBounds :: Plugin -> Prerequisite +getStandardBounds Plugin{plName = name, plVersion = version} = + (name,(Just version,Just (nextVersion version))) + where + nextVersion (Version (a:b:_) []) = Version [a,b+1] [] + nextVersion (Version [a] []) = Version [a,1] [] + nextVersion (Version [] []) = Version [1,1] [] diff --git a/src/Base/ConfigFile.hs b/src/Base/ConfigFile.hs new file mode 100644 --- /dev/null +++ b/src/Base/ConfigFile.hs @@ -0,0 +1,415 @@ +{-# OPTIONS_GHC -XTypeSynonymInstances -XExistentialQuantification #-} +----------------------------------------------------------------------------- +-- +-- Module : Base.ConfigFile +-- Copyright : Juergen Nicklisch-Franken +-- License : LGPL +-- +-- Maintainer : maintainer@leksah.org +-- Stability : provisional +-- Portability : portabel +-- +-- | Module for saving and restoring preferences and settings +-- in way similiar to what you would find in Microsoft Windows INI files. +-- +-- The configuration file may consists of sections, +-- led by a [section] header and followed by name: value entries +-- or it only contains name: value entries. + +-- Lines beginning with '#' or '--' (after optional whitespace) +-- are ignored and may be used to provide comments. + +-- Newlines may be added between a value, but the next line must begin with a whitespace +-- (names have to start at column 0, without preceeding whitespace). + +module Base.ConfigFile ( + + Printer +, Parser +, FieldDescriptionS(..) +, GenFieldDescriptionS(..) +, mkFieldS + +, applyFieldParsers +, boolParser +, intParser +, pairParser +, identifier +, emptyParser +, whiteSpace +, stringParser +, readParser +, versionParser +, parsePluginList +, showPluginList +, boundParser + +, emptyPrinter +, stringPrinter +, maybePP + +, symbol +, colon + +, showFields +, readFields +, parseFields + +, readFieldsSimple +, parseFieldsSimple +, showFieldsSimple +) where + +import Text.ParserCombinators.Parsec.Language +import qualified Text.ParserCombinators.Parsec.Token as P +import Text.ParserCombinators.Parsec hiding(Parser) +import qualified Text.PrettyPrint as PP + +import Data.Maybe (catMaybes, listToMaybe) +import Data.List (intersperse, foldl') +import Data.Version (showVersion, Version(..)) +import Base.PluginTypes (VersionBounds, PluginName, Prerequisite) +import Control.Monad (liftM) +import Base.MyMissing (maybeRead, myCast, trim) +import Data.Typeable (Typeable) + +--import Debug.Trace +trace a b = b + +-- ------------------------------------------------------------ +-- * Description of fields +-- ------------------------------------------------------------ + + +-- | A type for printing something +type Printer beta = beta -> PP.Doc + +-- | A type for parsing something +type Parser beta = CharParser () beta + +-- | A type for getting a field of a record +type Getter alpha beta = alpha -> beta + +-- | A type for setting the field of a record +type Setter alpha beta = beta -> alpha -> alpha + +-- | A description of a printable and parsable entity +data FieldDescriptionS alpha = FieldS { + fieldName :: String, + fieldPrinter :: alpha -> PP.Doc, + fieldParser :: alpha -> CharParser () alpha, + fieldSynopsis :: Maybe String + } + +data GenFieldDescriptionS = forall alpha . Typeable alpha => GenFS [FieldDescriptionS alpha] alpha + + +-- | A type for categories in ini files +type Category = String + +-- | Make a field description + +mkFieldS :: String -> + Maybe String -> + (Printer beta) -> + (Parser beta) -> + (Getter alpha beta) -> + (Setter alpha beta) -> + FieldDescriptionS alpha +mkFieldS name synopsis printer parser getter setter = + FieldS name + (\ dat -> (PP.text name PP.<> PP.colon) + PP.$$ (PP.nest 15 (printer (getter dat))) + PP.$$ (PP.nest 5 (case synopsis of + Nothing -> PP.empty + Just str -> PP.text $"--" ++ str))) + (\ dat -> (do + try (symbol name) + colon + value <- parser + return (setter value dat))) + synopsis + +-- ------------------------------------------------------------ +-- * Read and write +-- ------------------------------------------------------------ + +type PrefDescr = Either [(String,GenFieldDescriptionS)] + GenFieldDescriptionS + +showFields :: PrefDescr -> String +showFields (Right (GenFS dateDesc date)) = PP.render $ + foldl' (\ doc FieldS{fieldPrinter = printer} -> doc PP.$+$ printer date) + PP.empty dateDesc +showFields (Left catList) = PP.render $ PP.vcat (map showField' catList) + where + showField' (catString, (GenFS dateDesc date)) = + foldl' (\ doc FieldS{fieldPrinter = printer} -> doc PP.$+$ printer date) + (PP.text ("[" ++ catString ++ "]")) dateDesc + +readFields :: FilePath -> PrefDescr -> IO PrefDescr +readFields fn descrs = catch (do + res <- parseFromFile (parseFields' descrs) fn + case res of + Left pe -> error $ "Error reading file " ++ show pe + Right r -> return r) + (\ e -> error $ "Error reading file " ++ show e) + +parseFields :: String -> PrefDescr -> PrefDescr +parseFields str fieldDescrs = + case parse (parseFields' fieldDescrs) "" str of + Left pe -> error $ "Parse error " ++ show pe + Right r -> r + +parseFields' :: PrefDescr -> CharParser () PrefDescr +parseFields' (Right (GenFS fds defaultValue)) = + let parsersF = map fieldParser fds in do + res <- applyFieldParsers defaultValue parsersF + return (Right (GenFS fds res)) + "parseFields' parser1" +parseFields' (Left descrList) = do + newDescrList <- parseCategory [] descrList + return (Left newDescrList) + "parseFields' parser2" + +parseCategory :: [(String,GenFieldDescriptionS)] -> [(String,GenFieldDescriptionS)] + -> CharParser () [(String,GenFieldDescriptionS)] +parseCategory accu descrList = trace "parseCategory1" ( + do + eof + return accu + <|> do + name <- parseCatName + trace ("parseCategory2 " ++ name) ( + case [genFs | (n,genFs) <- descrList, n == name] of + [(GenFS fieldList defaultValue)] -> do + res <- applyFieldParsers defaultValue (map fieldParser fieldList) + parseCategory ((name,GenFS fieldList res) : accu) descrList + otherwise -> do + skipToNextCategory + parseCategory accu descrList) -- no error message, unknown categories are just skipped + "parseCategory") + +parseCatName :: CharParser () String +parseCatName = do + symbol "[" + str <- many (noneOf "]\n") + symbol "]" + return str + "parseCatName" + +skipToNextCategory :: CharParser () () +skipToNextCategory = do + eof + <|> do + many (noneOf "\n") + do + optional (char '\n') + c <- lookAhead anyChar + if c == '[' + then return () + else skipToNextCategory + "skipToNextCategory" + +applyFieldParsers :: a -> [a -> CharParser () a] -> CharParser () a +applyFieldParsers prefs parseF = trace "afp1" (do + eof + return (prefs)) + <|> trace "afp2" (do + lookAhead (char '[') + return (prefs)) + <|> trace "afp3" (do + let parsers = map (\a -> trace "xx" (a prefs)) parseF + newprefs <- choice parsers + whiteSpace + applyFieldParsers newprefs parseF) + trace "afp4" "applyFieldParsers" + +-- ------------------------------------------------------------ +-- * Convenience methods with simpler interfaces for files without category +-- ------------------------------------------------------------ + +readFieldsSimple :: Typeable alpha => FilePath -> [FieldDescriptionS alpha] -> alpha -> IO alpha +readFieldsSimple fn descriptions defaultValue = catch (do + putStrLn ("readFieldsSimple " ++ fn) + res <- parseFromFile (parseFields' (Right $ GenFS descriptions defaultValue)) fn + case res of + Left pe -> error $ "Error reading file " ++ show pe + Right (Right (GenFS _ r)) -> + return $ myCast "ConfigFile>>readFieldsSimple:" r + Right (Left _) -> error "ConfigFile>>readFieldsSimple: impossible") + (\ e -> error $ "Error reading file " ++ show e) + +parseFieldsSimple :: Typeable alpha => String -> [FieldDescriptionS alpha] -> alpha -> alpha +parseFieldsSimple str descriptions defaultValue = + let res = parseFields str (Right $ GenFS descriptions defaultValue) + in case res of + (Right (GenFS _ r)) -> myCast "ConfigFile>>parseFieldsSimple:" r + otherwise -> error "ConfigFile>>parseFieldsSimple: impossible" + +showFieldsSimple :: Typeable alpha => alpha -> [FieldDescriptionS alpha] -> String +showFieldsSimple date dateDesc = showFields (Right $ GenFS dateDesc date) + +-- ------------------------------------------------------------ +-- * Parsers and printers +-- ------------------------------------------------------------ + +-- A String parser parses some string, which may span multiple lines +-- Carriage returns are not significant +stringParser :: CharParser () String +stringParser = trace "str1" (do + firstLine <- many (noneOf ['\n']) + optional (char '\n') + lines <- many $ parseStringLine + let res = trim (unwords (firstLine : lines)) + trace ("stringParser \"" ++ res ++ "\"") $ return res) + "stringParser" + +parseStringLine :: CharParser () String +parseStringLine = trace "parseValueLine" (do + many1 (oneOf " \t") -- fails for lines which starts with a non blank + (do + char '-' -- skip comments + char '-' + many (noneOf ['\n']) + optional (char '\n') + return []) --skip comment + <|> (do + line <- many (noneOf ['\n']) + optional (char '\n') + return line) + trace "vl3" "parseValueLine") + +boolParser :: CharParser () Bool +boolParser = trace "bp1" (do + (symbol "True" <|> symbol "true") + return True) + <|> trace "bp2" (do + (symbol "False"<|> symbol "false") + return False) + "bool parser" + +readParser :: Read a => CharParser () a +readParser = trace "rp1" (do + str <- stringParser + trace ("readParser on:" ++ str) $ if null str + then unexpected "read parser on empty string" + else do + case maybeRead str of + Nothing -> unexpected $ "read parser no parse " ++ str + Just r -> return r) + "read parser" + +pairParser :: CharParser () alpha -> CharParser () (alpha,alpha) +pairParser p2 = trace "pp1" (do + parens $ do + v1 <- p2 + comma + v2 <- p2 + return (v1,v2)) + "pair parser" + +versionParser :: CharParser () Version +versionParser = trace "vp1" (do + branch <- sepBy1 intParser dot + return Version{versionBranch=branch, versionTags=[]}) + "version parser" + + +intParser :: CharParser () Int +intParser = trace "ip1" (do + i <- integer + return (fromIntegral i)) + "int parser" + +emptyParser :: CharParser () () +emptyParser = pzero + +prefsStyle :: P.LanguageDef st +prefsStyle = emptyDef { + P.commentStart = "{-" + , P.commentEnd = "-}" + , P.commentLine = "--" + } + +lexer :: P.TokenParser st +lexer = P.makeTokenParser prefsStyle + +whiteSpace :: CharParser st () +whiteSpace = P.whiteSpace lexer + +symbol :: String -> CharParser st String +symbol = P.symbol lexer + +identifier, colon :: CharParser st String +identifier = P.identifier lexer +colon = P.colon lexer +comma = P.comma lexer +parens = P.parens lexer +dot = P.dot lexer +integer = P.integer lexer +brackets = P.brackets lexer + +skipToCategory str = do + symbol ("[" ++ str ++ "]") + return () + <|> do + many (noneOf ['\n']) + char '\n' + skipToCategory str + + "skipToCategory" + +-- ------------------------------------------------------------ +-- * Printing +-- ------------------------------------------------------------ + +stringPrinter :: String -> PP.Doc +stringPrinter str = PP.fsep $ map PP.text (words str) + +emptyPrinter :: () -> PP.Doc +emptyPrinter _ = PP.empty + +maybePP :: (a -> PP.Doc) -> Maybe a -> PP.Doc +maybePP _ Nothing = PP.empty +maybePP pp (Just a) = pp a + + + +-- ------------------------------------------------------------ +-- * Special for plugins +------------------------------------------------------------ + +showPluginList :: [Prerequisite] -> String +showPluginList [] = "[]" +showPluginList l = "[" ++ concat (intersperse ", " (map showPlugin l)) ++ "]" + where + showPlugin (name,versionBounds) = "(" ++ name ++ "," ++ showVersionBounds versionBounds ++ ")" + showVersionBounds (a,b) = showBound a ++ "," ++ showBound b + showBound Nothing = "any" + showBound (Just v) = showVersion v + +parsePluginList :: CharParser () [Prerequisite] +parsePluginList = brackets (sepBy pluginParser comma) + +pluginParser :: CharParser () (PluginName, VersionBounds) +pluginParser = trace "pp1" ( + parens $ do + pluginName <- liftM trim (many (noneOf ",")) + comma + lowerBound <- boundParser + comma + upperBound <- boundParser + return (pluginName,(lowerBound,upperBound))) + "pluginParser" + +boundParser :: CharParser () (Maybe Version) +boundParser = + trace "bp1" (try $ do + v <- versionParser + return (Just v)) + <|> trace "bp2" (do + symbol "any" + return Nothing) + "boundParser" + diff --git a/src/Base/Event.hs b/src/Base/Event.hs new file mode 100644 --- /dev/null +++ b/src/Base/Event.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE RankNTypes, DeriveDataTypeable, StandaloneDeriving, TypeSynonymInstances, + FlexibleInstances, ExistentialQuantification, FlexibleContexts, TypeFamilies #-} + +----------------------------------------------------------------------------- +-- +-- Module : Base.Event +-- Copyright : Juergen Nicklisch-Franken +-- License : LGPL +-- +-- Maintainer : maintainer@leksah.org +-- Stability : provisional +-- Portability : portabel +-- +-- | Simple (imperative) event implementation +-- For concrete usage an event factory has to be constructed. +----------------------------------------------------------------------------- + +module Base.Event ( +-- * High level interface + makeEvent, + getEvent, + registerEvent, + registerEvent', + triggerEvent, + unionEvent, + filterEvent, + propagateEvent, + retriggerEvent, + +-- * Types + Handler, + Handlers(..), + EvtID, + HandlerID, + EventChannel(..), + EventFactory(..), + +-- * Low level interface + stdEventFactory, + mkEvent, + GenEvent(..), + newEventID +) where + +import Base.State +import Base.Selector + +import Data.Unique (newUnique, Unique) +import Data.Map (Map) +import Control.Monad.IO.Class +import qualified Data.Map as Map (empty, insert, lookup) +import Control.Monad (foldM) +import Data.IORef (newIORef, writeIORef, readIORef, IORef) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Maybe (fromJust) + +-- --------------------------------- +-- Types +-- + +-- +-- | A handler is a callback function +-- +type Handler event = event -> StateM event + +type EvtID = Unique +type HandlerID = Unique + +-- +-- | An event has a unique id, can be triggered, and callbacks can be registered +-- and unregistered +-- +data EventChannel event = EventChannel { + evtRegister :: Handler event -> HandlerID -> StateM (), + evtUnregister :: HandlerID -> StateM (), + evtTrigger :: event -> StateM event, + evtID :: EvtID} + + +-- +-- | A boxed type for events +-- +data GenEvent = forall event. GenEvent event + +-- +-- | The implementation type +-- +newtype Handlers event = Handlers (Map EvtID [(HandlerID, event -> StateM event)]) + +-- +-- | The provider of low level state mechanism +-- +data EventFactory event handlers = EventFactory { + efGetHandlers :: StateM handlers, + efSetHandlers :: handlers -> StateM ()} + +-- --------------------------------- +-- High level interface +-- + +-- +-- | Constructs a new event. The plugin name has to be unique! +-- +makeEvent + :: (ValueType alpha ~ EventChannel event, Selector alpha) => + alpha -> StateM (EventChannel event) +makeEvent selector = do + ideRef <- liftIO $ newIORef (Handlers Map.empty) + let ef = stdEventFactory selector ideRef + ev <- mkEvent selector ef + persistEvent selector ev + return ev + +persistEvent :: Selector alpha => alpha -> ValueType alpha -> StateM () +persistEvent key event = + registerState key event >> return () + +-- +-- | Get the event from a plugin name (The type has to fit, otherwise +-- an error will be thrown). +-- +getEvent :: Selector alpha => alpha -> StateM (ValueType alpha) +getEvent = getState + +-- +-- | Registers an event handler for this event +-- +registerEvent :: EventChannel alpha -> Handler alpha -> StateM (HandlerID) +registerEvent event handler = do + newEvtID <- liftIO $ newUnique + (evtRegister event) handler newEvtID + return newEvtID + +-- +-- | Registers an event handler for this event, without returning a Value +-- +registerEvent' :: EventChannel alpha -> (alpha -> StateM ()) -> StateM (HandlerID) +registerEvent' event handler = do + newEvtID <- liftIO $ newUnique + (evtRegister event) (\ e -> handler e >> return e) newEvtID + return newEvtID + +-- +-- | Triggers the event with the provided value +-- +triggerEvent :: (Selector alpha, ValueType alpha ~ EventChannel event) + => alpha -> event -> StateM event +triggerEvent sel e = getEvent sel >>= \ event -> (evtTrigger event) e + +-- +-- | Merge two event streams of the same type +-- +unionEvent :: EventChannel event -> EventChannel event -> StateM (EventChannel event) +unionEvent e1 e2 = do + newEvtID <- newEventID + return $ EventChannel { + evtRegister = \ handler newHdlIdID -> do + (evtRegister e1) handler newHdlIdID + (evtRegister e2) handler newHdlIdID, + evtUnregister = \ hdlID -> do + (evtUnregister e1) hdlID + (evtUnregister e2) hdlID, + evtTrigger = \ event -> do + (evtTrigger e1) event + (evtTrigger e2) event, + evtID = newEvtID} + +-- +-- | Allow all events that fulfill the predicate, discard the rest. Think of it as +-- +filterEvent :: (e -> Bool) -> EventChannel e -> StateM (EventChannel e) +filterEvent filterFunc event = do + newEvtID <- newEventID + return $ EventChannel { + evtRegister = \ handler newHdlId -> do + (evtRegister event) (newHandler handler) newHdlId, + evtUnregister = evtUnregister event, + evtTrigger = evtTrigger event, + evtID = newEvtID} + where + newHandler handler = \ event -> do + if filterFunc event + then handler event + else return event + +-- +-- | Propagate event ... +-- +propagateEvent :: EventChannel e -> [EventChannel e] -> StateM () +propagateEvent to fromList = + mapM_ (\ from -> registerEvent from (\e -> (evtTrigger to) e)) fromList + +retriggerEvent :: EventChannel e -> (e -> Maybe e) -> StateM () +retriggerEvent event trans = + registerEvent event (\e -> case trans e of + Nothing -> return e + Just ne -> (evtTrigger event) ne) >> return () + +-- --------------------------------- +-- Low level implementation +-- +stdEventFactory :: (Selector alpha, ValueType alpha ~ EventChannel event) => alpha -> + IORef (Handlers event) -> EventFactory event (Handlers event) +stdEventFactory _ handlersRef = EventFactory { + efGetHandlers = liftIO $ readIORef handlersRef, + efSetHandlers = \ nh -> liftIO $ writeIORef handlersRef nh} + +newEventID = liftIO $ newUnique + +-- +-- | Make an EventChannel in the IO Monad +-- +mkEvent + :: (Selector alpha, ValueType alpha ~ EventChannel event) => alpha + -> EventFactory event (Handlers event) + -> StateM (ValueType alpha) +mkEvent _ ef@EventFactory{efGetHandlers = getHandlers, efSetHandlers = setHandlers} = do + newEvtID <- newEventID + return $ EventChannel { + evtRegister = \ handler newUni -> do + Handlers handlerMap <- getHandlers + let newHandlers = case newEvtID `Map.lookup` handlerMap of + Nothing -> Map.insert newEvtID [(newUni,handler)] handlerMap + Just l -> Map.insert newEvtID ((newUni,handler):l) handlerMap + setHandlers (Handlers newHandlers), + evtUnregister = \ unique -> do + Handlers handlerMap <- getHandlers + let newHandlers = case newEvtID `Map.lookup` handlerMap of + Nothing -> handlerMap + Just l -> let newList = filter (\ (mu,_) -> mu /= unique) l + in Map.insert newEvtID newList handlerMap + setHandlers (Handlers newHandlers) + return (), + evtTrigger = \ event -> do + Handlers handlerMap <- getHandlers + case newEvtID `Map.lookup` handlerMap of + Nothing -> return event + Just l -> foldM (\ e (_,ah) -> ah e) event (reverse l), + evtID = newEvtID} + + + + + + diff --git a/src/Base/Graph.hs b/src/Base/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Base/Graph.hs @@ -0,0 +1,59 @@ +----------------------------------------------------------------------------- +-- +-- Module : Base.Graph +-- Copyright : Juergen Nicklisch-Franken +-- License : LGPL +-- +-- Maintainer : maintainer@leksah.org +-- Stability : provisional +-- Portability : portabel +-- +-- | A simple graph representation, based on Data.Graph +-- +----------------------------------------------------------------------------- + +module Base.Graph where + + +import Data.Map (Map) +import Data.Graph + (edges, graphFromEdges, Vertex, Graph, topSort, transposeG) +import Data.List ((\\), nub) +import qualified Data.Map as Map (insert, lookup, empty, toList) + + + +type MyGraph a = Map a [a] + +reverseGraph :: Ord alpha => MyGraph alpha -> MyGraph alpha +reverseGraph = withIndexGraph transposeG + +topSortGraph :: Ord alpha => MyGraph alpha -> [alpha] +topSortGraph myGraph = map ((\ (_,x,_)-> x) . lookup) $ topSort graph + where + (graph,lookup,_) = fromMyGraph myGraph + +withIndexGraph :: Ord alpha => (Graph -> Graph) -> MyGraph alpha -> MyGraph alpha +withIndexGraph idxOp myGraph = toMyGraph (idxOp graph) lookup + where + (graph,lookup,_) = fromMyGraph myGraph + +fromMyGraph :: Ord alpha => MyGraph alpha -> (Graph, Vertex -> ((), alpha , [alpha]), alpha -> Maybe Vertex) +fromMyGraph myGraph = + graphFromEdges + $ map (\(e,l)-> ((),e,l)) + $ graphList ++ map (\e-> (e,[])) missingEdges + where + mentionedEdges = nub $ concatMap snd graphList + graphList = Map.toList myGraph + missingEdges = mentionedEdges \\ map fst graphList + +toMyGraph :: Ord alpha => Graph -> (Vertex -> ((), alpha, [alpha])) -> MyGraph alpha +toMyGraph graph lookup = foldr constr Map.empty myEdges + where + constr (from,to) map = case Map.lookup from map of + Nothing -> Map.insert from [to] map + Just l -> Map.insert from (to : l) map + myEdges = map (\(a,b) -> (lookItUp a, lookItUp b)) $ edges graph + lookItUp = (\(_,e,_)-> e) . lookup + diff --git a/src/Base/MyMissing.hs b/src/Base/MyMissing.hs new file mode 100644 --- /dev/null +++ b/src/Base/MyMissing.hs @@ -0,0 +1,109 @@ +{-# OPTIONS_GHC -XScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- +-- Module : Base.MyMissing +-- Copyright : Juergen Nicklisch-Franken +-- License : LGPL +-- +-- Maintainer : maintainer@leksah.org +-- Stability : provisional +-- Portability : portabel +-- +-- | Module for missing base functions +-- +------------------------------------------------------------------------------ + +module Base.MyMissing ( + allOf +, forceJust +, forceHead +, splitString +, replace +, nonEmptyLines +, trim +, insertAt +, myCast +, maybeRead +) where + +import Data.List (find,unfoldr) +import Data.Maybe (listToMaybe, isJust) +import Data.Char (isSpace) +import Data.Typeable (cast, Typeable(..), Typeable) + + +-- | remove leading and trailing spaces +trim :: String -> String +trim = f . f + where f = reverse . dropWhile isSpace + +nonEmptyLines :: String -> [String] +nonEmptyLines = filter (\line -> isJust $ find (not . isSpace) line) . lines + + +allOf :: forall alpha. (Bounded alpha, Enum alpha) => [alpha] +allOf = map toEnum [fromEnum (minBound :: alpha) .. fromEnum (maxBound :: alpha)] + +-- --------------------------------------------------------------------- +-- Convenience methods with error handling +-- +forceJust :: Maybe alpha -> String -> alpha +forceJust mb str = case mb of + Nothing -> error str + Just it -> it + +-- --------------------------------------------------------------------- +-- Convenience methods with error handling +-- +forceHead :: [alpha] -> String -> alpha +forceHead (h:_) str = h +forceHead [] str = error str + + +-- --------------------------------------------------------------------- +-- Splitting a string into parts based on a token delimiter +-- + +splitString :: Eq a => a -> [a] -> [[a]] +splitString = unfoldr . split' + +split' :: Eq a => a -> [a] -> Maybe ([a], [a]) +split' c l + | null l = Nothing + | otherwise = Just (h, drop 1 t) + where (h, t) = span (/=c) l + +-- --------------------------------------------------------------------- +-- Simple replacement +-- + +replace :: Eq a => [a] -> [a] -> [a] -> [a] +replace _ _ [] = [] +replace from to xs@(a:as) = + if isPrefixOf from xs + then to ++ replace from to (drop (length from) xs) + else a : replace from to as + where isPrefixOf as bs = and $ zipWith (== ) as bs + +-- --------------------------------------------------------------------- +-- Insert in a list at index +-- +insertAt :: Int -> a -> [a] -> [a] +insertAt i e l | i < 0 = e : l + | i >= length l = l ++ [e] + | otherwise = let (start,end) = splitAt i l + in start ++ (e : end) + +-- | The type-safe cast operation +myCast :: forall a b . (Typeable a, Typeable b) => String -> a -> b +myCast errorString x = case cast x of + Just x' -> x' + Nothing -> error $ errorString ++ ". Cast error inputType: " ++ show (typeOf x) + ++ " outputType: " ++ show (typeOf (undefined :: a)) + +-- | a read which may fail + +maybeRead :: Read alpha => String -> Maybe alpha +maybeRead = listToMaybe . map fst . filter (null . snd) . reads + + diff --git a/src/Base/PluginTypes.hs b/src/Base/PluginTypes.hs new file mode 100644 --- /dev/null +++ b/src/Base/PluginTypes.hs @@ -0,0 +1,151 @@ +{-# Language DeriveDataTypeable, ExistentialQuantification, RankNTypes, FlexibleContexts, + TypeFamilies #-} + +----------------------------------------------------------------------------- +-- +-- Module : Base.PluginTypes +-- Copyright : Juergen Nicklisch-Franken +-- License : LGPL +-- +-- Maintainer : maintainer@leksah.org +-- Stability : provisional +-- Portability : portabel +-- +-- | Types module for Plugins +-- +----------------------------------------------------------------------------- + +module Base.PluginTypes where + +import Base.Event +import Base.State +import Base.Selector + +import Data.Version (showVersion, Version(..)) +import Data.Typeable (Typeable) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.IORef (newIORef) +import qualified Data.Map as Map (empty) +import Control.Monad (when) + +-- | The type of event this base component can trigger + +data MessageLevel = Debug | Info | Warning | Error + deriving(Eq,Ord,Show,Read) + +type BaseEvent = EventChannel BaseEventValue + +data BaseEventValue = StartUp | BaseLog MessageLevel String + +data PluginInterface event = + PluginInterface { + piInit1 :: BaseEvent -> EventChannel event -> StateM (), + piInit2 :: BaseEvent -> EventChannel event -> StateM (), + piEvent :: EventChannel event, + piName :: String, + piVersion :: Version} + +data GenInterfaceM = forall alpha . GenInterfaceM (StateM (PluginInterface alpha)) + +data GenInterface = forall event . GenInterface (PluginInterface event) + +-- | A PluginConfig is a configuration for an app, which is composed of plugins +data PluginConfig = PluginConfig { + cfName :: String, -- ^ name of the config + cfVersion :: Version, -- ^ version of the config + cfPlugins :: [Prerequisite], -- ^ plugins to load + cfChoices :: [Prerequisite], -- ^ other plugins + cfSynopsis :: String} -- ^ comment for this configuration + deriving (Eq,Ord,Show,Typeable) + +type PluginName = String + +-- | A plugin has +-- * a unique name +-- * a version +-- * a list of prerequisites +-- * maybe a comment +-- * a module and function name for getting a PluginConfig + +data Plugin = Plugin { + plName :: PluginName, + plVersion :: Version, + plPrerequisites :: [Prerequisite], + plChoices :: [Prerequisite], + plModule :: String, + plInterface :: String, + plSynopsis :: String} + deriving (Eq,Ord,Show, Read, Typeable) + +-- | Get the name of the plugin, which includes its version +getPluginName :: Plugin -> String +getPluginName Plugin{plName = name, plVersion = version} = name ++ "-" ++ showVersion version + +-- | An upper and a lower bound for versions, which may be omitted +type VersionBounds = (Maybe Version, Maybe Version) + +-- | A prerequisite is a pair of a plugin and version bounds +type Prerequisite = (PluginName, VersionBounds) + +type LoadList = [Plugin] + +data BaseEventSel = BaseEventSel + deriving (Eq,Ord,Show,Typeable) + +instance Selector BaseEventSel where + type ValueType BaseEventSel = EventChannel BaseEventValue + +-- | ConfigPathSel | MessageLevelSel + +triggerBaseEvent :: BaseEventValue -> StateM(BaseEventValue) +triggerBaseEvent = triggerEvent BaseEventSel + +getBaseEvent :: StateM (BaseEvent) +getBaseEvent = getEvent BaseEventSel + +registerBaseEvent :: Handler BaseEventValue -> StateM HandlerID +registerBaseEvent handler = getBaseEvent >>= \e -> registerEvent e handler + +data ConfigPathSel = ConfigPathSel + deriving (Eq,Ord,Show,Typeable) + +instance Selector ConfigPathSel where + type ValueType ConfigPathSel = FilePath + +setCurrentConfigPath :: FilePath -> StateM () +setCurrentConfigPath = setState ConfigPathSel + +getCurrentConfigPath :: StateM FilePath +getCurrentConfigPath = getState ConfigPathSel + +registerCurrentConfigPath :: FilePath -> StateM (Maybe String) +registerCurrentConfigPath = registerState ConfigPathSel + +data MessageLevelSel = MessageLevelSel + deriving (Eq,Ord,Show,Read,Typeable) + +instance Selector MessageLevelSel where + type ValueType MessageLevelSel = MessageLevel + +setMessageLevel :: MessageLevel -> StateM () +setMessageLevel = setState MessageLevelSel + +getMessageLevel :: StateM MessageLevel +getMessageLevel = getState MessageLevelSel + +registerMessageLevel :: MessageLevel -> StateM (Maybe String) +registerMessageLevel = registerState MessageLevelSel + +-- +-- | Outputs a message. Triggers the BaseEvent BaseLog, which is in this +-- package handled to ~BaseLog level str -> liftIO $ putStrLn (show level ++ " " ++ str)~ +message :: MessageLevel -> String -> StateM () +message level str = do + fromLevel <- getMessageLevel + when (level >= fromLevel) $ do + triggerBaseEvent (BaseLog level str) >> return () + + +messageR :: MessageLevel -> String -> StateRef -> IO () +messageR level str = reflectState (message level str) + diff --git a/src/Base/Selector.hs b/src/Base/Selector.hs new file mode 100644 --- /dev/null +++ b/src/Base/Selector.hs @@ -0,0 +1,54 @@ +{-# Language StandaloneDeriving, DeriveDataTypeable, ExistentialQuantification, + TypeFamilies #-} + +----------------------------------------------------------------------------- +-- +-- Module : Base.Selector +-- Copyright : Juergen Nicklisch-Franken +-- License : LGPL +-- +-- Maintainer : maintainer@leksah.org +-- Stability : provisional +-- Portability : portabel +-- +-- | A Selector is a unique think, which has an attached type for values. +-- It's String representation is not necessary unique! +-- +----------------------------------------------------------------------------- + +module Base.Selector ( + Selector(..), + GenSelector(..), + +) where + +import Data.Typeable (typeRepKey, cast, Typeable(..), Typeable) +import Data.Maybe (fromJust) +import System.IO.Unsafe (unsafePerformIO) + +---- +---- | A type family for unique selectors +---- +class (Eq alpha, Ord alpha, Show alpha, Typeable alpha) => Selector alpha where + type ValueType alpha :: * + +-- +-- | Boxing for selectors +-- +data GenSelector = forall alpha . Selector alpha => GS alpha + +deriving instance Show GenSelector + + +-- | Equality and comparision for selectors + +instance Eq GenSelector where + (==) (GS a) (GS b) = if typeOf a == typeOf b then + fromJust (cast a) == b + else False + +instance Ord GenSelector where + compare (GS a) (GS b) = if typeOf a == typeOf b then + compare (fromJust (cast a)) b + else compare (unsafePerformIO $ typeRepKey $ typeOf a) + (unsafePerformIO $ typeRepKey $ typeOf b) diff --git a/src/Base/State.hs b/src/Base/State.hs new file mode 100644 --- /dev/null +++ b/src/Base/State.hs @@ -0,0 +1,233 @@ +{-# Language ExistentialQuantification, ScopedTypeVariables, StandaloneDeriving, + DeriveDataTypeable, FlexibleContexts #-} + +----------------------------------------------------------------------------- +-- +-- Module : Base.State +-- Copyright : Juergen Nicklisch-Franken +-- License : LGPL +-- +-- Maintainer : maintainer@leksah.org +-- Stability : provisional +-- Portability : portabel +-- +-- | A simple state service. +-- A state has to br registered with an initial value, before it can be used. +-- +----------------------------------------------------------------------------- + +module Base.State ( +-- * High level interface + registerState, + setState, + getState, + hasState, + withState, + runState, + +-- * Convenience functions + reifyState, + reflectState, + runInIO, + catchState, + forkState, + +-- * Types + TheState, + StateRef, + StateM, + StateAction, + GenState(..), + +-- * Low level interface + registerState', +) where + +import Base.Selector + +import Data.IORef + (atomicModifyIORef, readIORef, writeIORef, newIORef, IORef) +import Control.Monad.Reader (ReaderT(..)) +import qualified Data.Map as Map (insert, lookup, empty) +import Data.Map (Map) +import Control.Monad.Reader.Class (MonadReader(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad (liftM) +import Data.Maybe (fromJust, isJust) +import Control.Exception (catch, Exception) +import Control.Concurrent (forkIO) +import Prelude hiding (catch) +import Unsafe.Coerce (unsafeCoerce) + +-- +-- | A state is a Map from a selector to something +-- +type State a = Map GenSelector a + +-- +-- | The special types getting lost here, but can be recovered by attaching runtime +-- type information via Typeable +-- +data GenState = forall alpha . GenState alpha + +-- +-- | The concrete state is build from this +-- +type TheState = State GenState + +-- +-- | A mutable reference to the IDE state +-- +type StateRef = IORef TheState + +-- +-- | The IDE Monad +-- +type StateM = ReaderT StateRef IO + +-- +-- | A shorthand for a reader monad for a mutable reference to the IDE state +-- which does not return a value +-- +type StateAction = StateM () + +-- +-- | Initial call for the state service, +-- everything has to happen now inside this monad +-- +runState :: StateM a -> IO a +runState f = do + ref :: StateRef <- newIORef Map.empty + reflectState f ref + +-- +-- | Lift an IO action to an IDE action +-- +reifyState :: (StateRef -> IO a) -> StateM a +reifyState = ReaderT + +runInIO :: forall alpha beta. (beta -> StateM alpha) -> StateM (beta -> IO alpha) +runInIO f = reifyState (\ideRef -> return (\v -> reflectState (f v) ideRef)) + +-- +-- | Do an IDE action in the IO monad +-- +reflectState :: StateM a -> StateRef -> IO a +reflectState c ideR = runReaderT c ideR + +catchState :: Exception e => StateM a -> (e -> StateM a) -> StateM a +catchState block handler = reifyState (\ideR -> catch (reflectState block ideR) (handler' ideR)) + where + handler' ideR = (\ f e -> reflectState (f e) ideR) handler + +forkState :: StateAction -> StateAction +forkState block = reifyState (\ideR -> forkIO (reflectState block ideR) >> return ()) + + +-- --------------------------------------------------------------------- +-- * Methods for accesing the IDE State +-- + +-- +-- | Read an attribute of the contents +-- +readStateM :: (TheState -> beta) -> StateM beta +readStateM f = do + e <- ask + liftIO $ liftM f (readIORef e) + +-- +-- | Modify the contents, without returning a value +-- +modifyStateM_ :: (TheState -> TheState) -> StateM () +modifyStateM_ f = let f' a = (f a,()) in do + e <- ask + liftIO (atomicModifyIORef e f') + +-- +-- | Variation on modifyIDE_ that lets you return a value +-- +modifyStateM :: (TheState -> (TheState,beta)) -> StateM beta +modifyStateM f = do + e <- ask + liftIO (atomicModifyIORef e f) + +-- +-- | Call a function in the IO Monad with the state and return the result +-- +withStateM :: (TheState -> IO alpha) -> StateM alpha +withStateM f = do + e <- ask + liftIO $ f =<< readIORef e + +-- +-- | Gets the state +-- +getStateM :: StateM(TheState) +getStateM = do + e <- ask + st <- liftIO $ readIORef e + return st + +-- +-- | Registers a key and sets the value. Returns nothing if everything works, +-- else just an error string +-- +registerState :: Selector alpha => alpha -> ValueType alpha -> StateM (Maybe String) +registerState key value = do + hasIt <- hasState key + if hasIt then return $ Just $ "State>>registerState: " ++ + "State already registered " ++ show key + else modifyStateM_ (\st -> Map.insert (GS key) (GenState value) st) >> return Nothing + +-- +-- | Registers a key +-- +registerState' :: Selector alpha => alpha -> GenState -> StateM (Maybe String) +registerState' key value = do + hasIt <- hasState key + if hasIt then return $ Just $ "State>>registerState: " ++ + "State already registered " ++ show key + else modifyStateM_ (\st -> Map.insert (GS key) value st) >> return Nothing + +-- +-- | Set a value for a key +-- +setState :: Selector alpha => alpha -> ValueType alpha -> StateM () +setState key value = modifyStateM_ (\ st -> case GS key `Map.lookup` st of + Nothing -> error $ "State>>setState: " ++ + "State not registered " ++ show key + Just _ -> Map.insert (GS key) (GenState value) st) + +-- +-- | Get a value for a key +-- +getState :: Selector alpha => alpha -> StateM (ValueType alpha) +getState key = readStateM (\st -> case (GS key) `Map.lookup` st of + Nothing -> error $ "State>>getState: " ++ + "State not registered " ++ show key + Just (GenState v) -> unsafeCoerce v) + +-- +-- | Is this state registered? +-- +hasState :: Selector alpha => alpha -> StateM Bool +hasState sel = readStateM (\st -> case GS sel `Map.lookup` st of + Nothing -> False + Just _ -> True) + +-- +-- | Do the function with the state and set the result as new value +-- +withState :: Selector alpha => alpha -> (ValueType alpha -> ValueType alpha) -> StateM () +withState key f = + modifyStateM_ + (\ st -> case (GS key) `Map.lookup` st of + Nothing -> error $ "State>>withState: " ++ + "State not registered " ++ show key + Just (GenState v) -> + let nv = f (unsafeCoerce v) + in Map.insert (GS key) (GenState nv) st) + + +