billeksah-services (empty) → 1.0.0
raw patch · 12 files changed
+1777/−0 lines, 12 filesdep +basedep +containersdep +directorysetup-changed
Dependencies added: base, containers, directory, filepath, mtl, parsec, pretty, transformers
Files
- LICENSE +165/−0
- Setup.lhs +6/−0
- billeksah-services.cabal +43/−0
- src/Base.hs +33/−0
- src/Base/Config.hs +264/−0
- src/Base/ConfigFile.hs +415/−0
- src/Base/Event.hs +245/−0
- src/Base/Graph.hs +59/−0
- src/Base/MyMissing.hs +109/−0
- src/Base/PluginTypes.hs +151/−0
- src/Base/Selector.hs +54/−0
- src/Base/State.hs +233/−0
+ LICENSE view
@@ -0,0 +1,165 @@+ GNU LESSER GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ 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.
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain+
+ billeksah-services.cabal view
@@ -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++
+ src/Base.hs view
@@ -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
+ src/Base/Config.hs view
@@ -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] []
+ src/Base/ConfigFile.hs view
@@ -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"+
+ src/Base/Event.hs view
@@ -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}++++++
+ src/Base/Graph.hs view
@@ -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+
+ src/Base/MyMissing.hs view
@@ -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++
+ src/Base/PluginTypes.hs view
@@ -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)+
+ src/Base/Selector.hs view
@@ -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)
+ src/Base/State.hs view
@@ -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)+++