-- GenI surface realiser -- Copyright (C) 2005 Carlos Areces and Eric Kow -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License -- as published by the Free Software Foundation; either version 2 -- of the License, or (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings, ViewPatterns #-} module NLP.GenI.Configuration ( Params(..) -- , mainBuilderTypes , getFlagP, getListFlagP, modifyFlagP, setFlagP, hasFlagP, deleteFlagP, hasOpt , emptyParams, defineParams , treatArgs, treatArgsWithParams, usage, basicSections, optionsSections , processInstructions , optionsForStandardGenI , optionsForBasicStuff, optionsForOptimisation, optionsForMorphology, optionsForInputFiles , optionsForBuilder, optionsForTesting , helpOption, verboseOption, macrosOption, lexiconOption , nubBySwitches , noArg, reqArg, optArg , parseFlagWithParsec -- * configration files , readGlobalConfig, setLoggers -- re-exports , module System.Console.GetOpt , module NLP.GenI.Flag , Typeable ) where import Control.Applicative ( (<$>), pure ) import Control.Arrow ( first ) import Control.Monad ( liftM ) import Data.Char ( toLower, isSpace ) import Data.List ( find, intersperse, nubBy ) import Data.Maybe ( fromMaybe, isNothing, fromJust ) import Data.Maybe ( listToMaybe, mapMaybe ) import Data.String ( IsString(..) ) import Data.Text ( Text ) import Data.Typeable ( Typeable ) import System.Directory ( getAppUserDataDirectory, doesFileExist ) import System.Environment ( getProgName ) import System.FilePath import System.IO ( stderr ) import Text.ParserCombinators.Parsec ( runParser, CharParser ) import qualified Data.ByteString.Char8 as BC import qualified Data.Map as Map import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Yaml.YamlLight import System.Console.GetOpt import System.Log.Formatter import System.Log.Handler ( LogHandler, setFormatter ) import System.Log.Handler.Simple import System.Log.Logger import NLP.GenI.Flag import NLP.GenI.General ( geniBug, fst3, snd3 ) import NLP.GenI.Parser ( geniFeats, tillEof ) import NLP.GenI.Morphology.Types ( MorphRealiser ) import NLP.GenI.Pretty import NLP.GenI.Polarity.Types ( readPolarityAttrs ) import NLP.GenI.LexicalSelection ( LexicalSelector ) -- -------------------------------------------------------------------- -- Params -- -------------------------------------------------------------------- -- | Holds the specification for how Geni should be run, its input -- files, etc. This is the stuff that would normally be found in -- the configuration file. data Params = Params { grammarType :: GrammarType , builderType :: BuilderType -- | Can still be overridden with a morph command mind you , customMorph :: Maybe MorphRealiser -- | Lexical selection function -- (if you set this you may want to add 'PreAnchored' to the config) , customSelector :: Maybe LexicalSelector , geniFlags :: [Flag] } {- instance Show Params where show p = unlines [ unwords [ "GenI config :", show (grammarType p), show (builderType p), morph ] , unwords $ "GenI flags :" : map show (geniFlags p) ] where morph = "custom morph:" ++ show (isJust (customMorph p)) -} -- | The default parameters configuration emptyParams :: Params emptyParams = Params { builderType = SimpleBuilder , grammarType = GeniHand , customMorph = Nothing , customSelector = Nothing , geniFlags = emptyFlags } hasOpt :: Optimisation -> Params -> Bool hasOpt o p = maybe False (elem o) $ getFlagP OptimisationsFlg p hasFlagP :: (Typeable f, Typeable x) => (x -> f) -> Params -> Bool hasFlagP f = hasFlag f . geniFlags deleteFlagP :: (Typeable f, Typeable x) => (x -> f) -> Params -> Params deleteFlagP f p = p { geniFlags = deleteFlag f (geniFlags p) } modifyFlagP :: (Eq f, Typeable f, Typeable x) => (x -> f) -> (x -> x) -> Params -> Params modifyFlagP f m p = p { geniFlags = modifyFlag f m (geniFlags p) } setFlagP :: (Eq f, Typeable f, Typeable x) => (x -> f) -> x -> Params -> Params setFlagP f v p = p { geniFlags = setFlag f v (geniFlags p) } getFlagP :: (Typeable f, Typeable x) => (x -> f) -> Params -> Maybe x getFlagP f = getFlag f . geniFlags getListFlagP :: (Typeable f, Typeable x) => ([x] -> f) -> Params -> [x] getListFlagP f = fromMaybe [] . getFlagP f emptyFlags :: [Flag] emptyFlags = [ Flag ViewCmdFlg "ViewTAG" , Flag DetectPolaritiesFlg $ readPolarityAttrs defaultPolarityAttrs , Flag RootFeatureFlg $ parseFlagWithParsec "default root feat" geniFeats defaultRootFeat ] -- -------------------------------------------------------------------- -- Command line arguments -- -------------------------------------------------------------------- type OptSection = (String,[OptDescr Flag],[String]) -- | Uses the GetOpt library to process the command line arguments. -- Note that we divide them into basic and advanced usage. optionsForStandardGenI :: [OptDescr Flag] optionsForStandardGenI = nubBySwitches $ concatMap snd3 optionsSections ++ [ Option ['p'] [] (reqArg WeirdFlg id "CMD") "" ] -- TODO: what is this -p flag for, exactly? It's something -- related to how GenI runs within an app bundle. Can we -- do away with it? basicSections :: [OptSection] basicSections = map tweakBasic $ take 1 optionsSections where tweakBasic (x,y,z) = (x,y,z ++ ["See --help for more options"]) optionsSections :: [OptSection] optionsSections = [ ("Core options", optionsForBasicStuff, example) , ("Input", optionsForInputFiles, []) , ("Output", optionsForOutput, []) , ("Algorithm", (nubBySwitches $ optionsForBuilder ++ optionsForOptimisation), usageForOptimisations) , ("Morphology", optionsForMorphology, []) , ("User interface", optionsForUserInterface, []) , ("Batch processing", optionsForTesting, []) ] where example = [ "Example:" , " geni -m examples/ej/mac -l examples/ej/lexicon -s examples/ej/suite" ] getSwitches :: OptDescr a -> ([Char],[String]) getSwitches (Option s l _ _) = (s,l) nubBySwitches :: [OptDescr a] -> [OptDescr a] nubBySwitches = nubBy (\x y -> getSwitches x == getSwitches y) -- GetOpt wrappers noArg :: forall f . (Eq f, Typeable f) => (() -> f) -> ArgDescr Flag noArg s = NoArg (Flag s ()) reqArg :: forall f x . (Eq f, Typeable f, Eq x, Typeable x) => (x -> f) -- ^ flag -> (String -> x) -- ^ string reader for flag (probably |id| if already a String) -> String -- ^ description -> ArgDescr Flag reqArg s fn desc = ReqArg (\x -> Flag s (fn x)) desc optArg :: forall f x . (Eq f, Typeable f, Eq x, Typeable x) => (x -> f) -- ^ flag -> x -- ^ default value -> (String -> x) -- ^ string reader (as in @reqArg@) -> String -- ^ description -> ArgDescr Flag optArg s def fn desc = OptArg (\x -> Flag s (maybe def fn x)) desc -- ------------------------------------------------------------------- -- Parsing command line arguments -- ------------------------------------------------------------------- -- | Print out a GenI-style usage message with options divided into sections usage :: [OptSection] -- ^ options -> String -- ^ prog name -> String usage sections pname = let header = "Usage: " ++ pname ++ " [OPTION...]\n" body = unlines $ map usageSection sections in header ++ body usageSection :: (String, [OptDescr Flag],[String]) -> String usageSection (name, opts, comments) = usageInfo (unlines $ [bar,name, bar]) opts ++ mcomments where bar = replicate 72 '=' mcomments = if null comments then [] else "\n" ++ unlines comments treatArgs :: [OptDescr Flag] -> [String] -> IO Params treatArgs options argv = treatArgsWithParams options argv emptyParams treatArgsWithParams :: [OptDescr Flag] -> [String] -> Params -> IO Params treatArgsWithParams options argv initParams = case getOpt Permute options argv of (os,_,[] )-> return $ defineParams os initParams (_,_,errs) -> do p <- getProgName ioError (userError $ concat errs ++ usage basicSections p) defineParams :: [Flag] -> Params -> Params defineParams flgs prms = (\p -> foldr setDefault p $ geniFlags prms) . (mergeFlagsP OptimisationsFlg) . (mergeFlagsP MetricsFlg) $ prms { geniFlags = flgs , builderType = fromFlags builderType BuilderFlg flgs , grammarType = fromFlags grammarType GrammarTypeFlg flgs } where setDefault (Flag f v) p = if hasFlagP f p then p else setFlagP f v p mergeFlagsP f p = if hasFlagP f p then setFlagP f (concat $ getAllFlags f flgs) p else p fromFlags default_ t fs = fromMaybe (default_ prms) (getFlag t fs) -- -------------------------------------------------------------------- -- Basic options -- -------------------------------------------------------------------- optionsForBasicStuff :: [OptDescr Flag] optionsForBasicStuff = [ helpOption, verboseOption, noguiOption , macrosOption , lexiconOption, testSuiteOption , rootFeatureOption , outputOption ] -- -------------------------------------------------------------------- -- Input files -- -------------------------------------------------------------------- optionsForInputFiles :: [OptDescr Flag] optionsForInputFiles = [ macrosOption , lexiconOption , tracesOption , testSuiteOption , fromStdinOption , morphInfoOption , instructionsOption , rankingOption , Option [] ["preselected"] (NoArg (Flag GrammarTypeFlg PreAnchored)) "do NOT perform lexical selection - treat the grammar as the selection" ] instructionsOption, macrosOption, lexiconOption, tracesOption :: OptDescr Flag instructionsOption = Option [] ["instructions"] (reqArg InstructionsFileFlg id "FILE") "instructions file FILE" macrosOption = Option ['t','m'] ["trees","macros"] (reqArg MacrosFlg id "FILE") "tree schemata file FILE (unanchored trees)" lexiconOption = Option ['l'] ["lexicon"] (reqArg LexiconFlg id "FILE") "lexicon file FILE" tracesOption = Option [] ["traces"] (reqArg TracesFlg id "FILE") "traces file FILE (list of traces to display)" rankingOption :: OptDescr Flag rankingOption = Option [] ["ranking"] (reqArg RankingConstraintsFlg id "FILE") "ranking constraints FILE (using Optimality Theory)" -- -------------------------------------------------------------------- -- Output -- -------------------------------------------------------------------- optionsForOutput :: [OptDescr Flag] optionsForOutput = [ outputOption , Option [] ["dump"] (noArg DumpDerivationFlg) "print derivation information on stdout (JSON)" -- same as rankingOption but with output-centric help text , partialOption , Option [] ["ranking"] (reqArg RankingConstraintsFlg id "FILE") "use constraints in FILE to rank output" ] partialOption :: OptDescr Flag partialOption = Option [] ["partial"] (noArg PartialFlg) "return partial result(s) if no complete solution is found" outputOption :: OptDescr Flag outputOption = Option ['o'] ["output"] (reqArg OutputFileFlg id "FILE") "output file FILE (stdout if unset)" -- -------------------------------------------------------------------- -- User interface -- -------------------------------------------------------------------- optionsForUserInterface :: [OptDescr Flag] optionsForUserInterface = [ noguiOption, helpOption, versionOption , Option [] ["viewcmd"] (reqArg ViewCmdFlg id "CMD") "XMG tree-view command" ] noguiOption :: OptDescr Flag noguiOption = Option [] ["nogui"] (noArg DisableGuiFlg) "disable graphical user interface" helpOption :: OptDescr Flag helpOption = Option [] ["help"] (noArg HelpFlg) "show full list of command line switches" versionOption :: OptDescr Flag versionOption = Option [] ["version"] (noArg VersionFlg) "display the version" verboseOption :: OptDescr Flag verboseOption = Option ['v'] ["verbose"] (noArg VerboseModeFlg) "verbose mode" -- -------------------------------------------------------------------- -- Optimisations -- -------------------------------------------------------------------- defaultPolarityAttrs :: String defaultPolarityAttrs = "cat" exampleRootFeat :: String exampleRootFeat = "[cat:s inv:- mode:ind|subj wh:-]" defaultRootFeat :: String defaultRootFeat = "[cat:_]" optionsForOptimisation :: [OptDescr Flag] optionsForOptimisation = [ Option [] ["opts"] (reqArg OptimisationsFlg readOptimisations "LIST") "optimisations 'LIST' (--help for details)" , Option [] ["detect-pols"] (reqArg DetectPolaritiesFlg readPolarityAttrs "LIST") ("attributes 'LIST' (eg. \"cat idx V.tense\", default:" ++ show defaultPolarityAttrs ++ ")") , rootFeatureOption , maxResultsOption ] rootFeatureOption :: OptDescr Flag rootFeatureOption = Option ['r'] ["rootfeat"] (reqArg RootFeatureFlg readRF "FEATURE") ("root features 'FEATURE' (eg. " ++ prettyStr exampleRF ++ ", default: " ++ prettyStr defaultRF ++ ")") where exampleRF = readRF exampleRootFeat defaultRF = readRF defaultRootFeat readRF = parseFlagWithParsec "root feature" geniFeats coreOptimisationCodes :: [(Optimisation,String,String)] coreOptimisationCodes = [ (Polarised , "p", "polarity filtering") , (NoConstraints , "nc", "disable semantic constraints (anti-optimisation!)") ] optimisationCodes :: [(Optimisation,String,String)] optimisationCodes = coreOptimisationCodes ++ [ (PolOpts , "pol", equivalentTo polOpts) , (AdjOpts , "adj", equivalentTo adjOpts) ] where equivalentTo os = "equivalent to '" ++ (unwords $ map showOptCode os) ++ "'" polOpts, adjOpts :: [Optimisation] polOpts = [Polarised] adjOpts = [] -- --------------------------------------------------------------------- -- Optimisation usage info -- --------------------------------------------------------------------- lookupOpt:: Optimisation -> (String, String) lookupOpt k = case find (\x -> k == fst3 x) optimisationCodes of Just (_, c, d) -> (c, d) Nothing -> geniBug $ "optimisation " ++ show k ++ " unknown" showOptCode :: Optimisation -> String showOptCode = fst.lookupOpt describeOpt :: (Optimisation, String, String) -> String describeOpt (_,k,d) = k ++ " - " ++ d -- | Displays the usage text for optimisations. -- It shows a table of optimisation codes and their meaning. usageForOptimisations :: [String] usageForOptimisations = [ "Optimisations must be passed in as a space-delimited list" , "(ex: --opt='p f-sem' for polarities and semantic filtering)" , "" , "Optimisations:" , " " ++ unlinesTab (map describeOpt coreOptimisationCodes) ] where unlinesTab l = concat (intersperse "\n " l) -- --------------------------------------------------------------------- -- Parsing optimisation stuff -- --------------------------------------------------------------------- -- | If we do not recognise a code, we output an error message. We -- also take the liberty of expanding thematic codes like 'pol' -- into the respective list of optimisations. readOptimisations :: String -> [Optimisation] readOptimisations str = case parseOptimisations str of Left ick -> error $ "Unknown optimisations: " ++ (unwords ick) Right os -> (addif PolOpts polOpts) . (addif AdjOpts adjOpts) $ os where addif t x o = if (t `elem` o) then x ++ o else o -- | Returns |Left| for any codes we don't recognise, or -- |Right| if everything is ok. parseOptimisations :: String -> Either [String] [Optimisation] parseOptimisations str = let codes = words str mopts = map lookupOptimisation codes in if any isNothing mopts then Left [ c | (c,o) <- zip codes mopts, isNothing o ] else Right $ map fromJust mopts lookupOptimisation :: String -> Maybe Optimisation lookupOptimisation code = liftM fst3 $ find (\x -> snd3 x == code) optimisationCodes -- | TODO: This is a horrible and abusive use of 'error' parseFlagWithParsec :: String -> CharParser () b -> String -> b parseFlagWithParsec description p str = case runParser (tillEof p) () "" str of Left err -> error $ "Couldn't parse " ++ description ++ " because " ++ show err Right res -> res -- -------------------------------------------------------------------- -- Builders -- -------------------------------------------------------------------- optionsForBuilder :: [OptDescr Flag] optionsForBuilder = [ Option ['b'] ["builder"] (reqArg BuilderFlg readBuilderType "BUILDER") ("use as realisation engine one of: " ++ (unwords $ map show mainBuilderTypes)) , partialOption , maxStepsOption , maxResultsOption ] mainBuilderTypes :: [BuilderType] mainBuilderTypes = [ SimpleBuilder, SimpleOnePhaseBuilder ] -- | Hint: compose with (map toLower) to make it case-insensitive mReadBuilderType :: String -> Maybe BuilderType mReadBuilderType "simple" = Just SimpleBuilder mReadBuilderType "simple-2p" = Just SimpleBuilder mReadBuilderType "simple-1p" = Just SimpleOnePhaseBuilder mReadBuilderType _ = Nothing -- | Is case-insensitive, error if unknown type readBuilderType :: String -> BuilderType readBuilderType b = case mReadBuilderType $ map toLower b of Just x -> x Nothing -> error $ "Unknown builder type " ++ b -- -------------------------------------------------------------------- -- Testing and profiling -- -------------------------------------------------------------------- fromStdinOption :: OptDescr Flag fromStdinOption = Option [] ["from-stdin"] (noArg FromStdinFlg) "get testcase from stdin" testSuiteOption :: OptDescr Flag testSuiteOption = Option ['s'] ["testsuite"] (reqArg TestSuiteFlg id "FILE") "test suite FILE" maxResultsOption :: OptDescr Flag maxResultsOption = Option [] ["maxresults"] (reqArg MaxResultsFlg read "INT") "return as soon as at least INT results are found" maxStepsOption :: OptDescr Flag maxStepsOption = Option [] ["maxsteps"] (reqArg MaxStepsFlg read "INT") "abort and return any results found after INT steps" optionsForTesting :: [OptDescr Flag] optionsForTesting = [ testSuiteOption , fromStdinOption , Option [] ["testcase"] (reqArg (TestCaseFlg . T.pack) id "STRING") "run test case STRING" , Option [] ["timeout"] (reqArg TimeoutFlg read "SECONDS") "time out after SECONDS seconds" , maxResultsOption , maxStepsOption , Option [] ["metrics"] (optArg MetricsFlg ["default"] words "LIST") "keep track of performance metrics: (default: iterations comparisons chart_size)" , Option [] ["statsfile"] (reqArg StatsFileFlg id "FILE") "write performance data to file FILE (stdout if unset)" , Option [] ["batchdir"] (reqArg BatchDirFlg id "DIR") "batch process the test suite and save results to DIR" , Option [] ["earlydeath"] (noArg EarlyDeathFlg) "exit on first case with no results (batch processing) " ] -- -------------------------------------------------------------------- -- Morphology -- -------------------------------------------------------------------- optionsForMorphology :: [OptDescr Flag] optionsForMorphology = [ morphInfoOption , Option [] ["morphcmd"] (reqArg MorphCmdFlg id "CMD") "morphological post-processor CMD (default: unset)" ] morphInfoOption :: OptDescr Flag morphInfoOption = Option [] ["morphinfo"] (reqArg MorphInfoFlg id "FILE") "morphological features FILE (default: unset)" -- ==================================================================== -- Scripting GenI -- ==================================================================== -- | Update the internal instructions list, test suite and case -- according to the contents of an instructions file. -- -- Basic approach -- -- * we always have instructions: if no instructions file, is specified -- we infer virtual instructions from the test suite flag -- * the testsuite and testcase flags are focusing tools, they pick out -- a subset from the instructions processInstructions :: Params -> IO Params processInstructions config = do instructions <- case getFlagP InstructionsFileFlg config of Nothing -> return fakeInstructions Just f -> instructionsFile `fmap` T.readFile f let updateInstructions = setFlagP TestInstructionsFlg instructions -- we have to set a test suite in case the user only supplies -- an instructions argument so that NLP.GenI.loadEverything -- knows that the user has given us a suite to load updateTestSuite p = if hasFlagP TestSuiteFlg p then p else case (fst `fmap` listToMaybe instructions) of Just s -> setFlagP TestSuiteFlg s p Nothing -> p return . updateTestSuite . updateInstructions $ config where fakeInstructions :: [Instruction] fakeInstructions = let cases = singleton <$> getFlagP TestCaseFlg config mkInstr xs = singleton (xs, cases) in maybe [] mkInstr $ getFlagP TestSuiteFlg config instructionsFile :: Text -> [Instruction] instructionsFile = mapMaybe inst . T.lines where inst l = case T.words (T.takeWhile (/= '%') l) of [] -> Nothing [f] -> Just (T.unpack f, Nothing) (f:cs) -> Just (T.unpack f, Just cs) -- ==================================================================== -- Configuration file -- ==================================================================== readGlobalConfig :: IO (Maybe YamlLight) readGlobalConfig = do geniCfgDir <- getAppUserDataDirectory "geni" let globalCfg = geniCfgDir "config.yaml" hasCfg <- doesFileExist globalCfg if hasCfg then Just `fmap` parseYamlFile globalCfg else return Nothing data LoggerConfig = LoggerConfig { lcName :: String , lcPriority :: Priority , lcHandler :: LogTo , lcFormatter :: LogFmt } deriving Show data LogTo = LogToFile FilePath | LogToErr deriving Show data LogFmt = LogFmtNull | LogFmtSimple String deriving Show logDefaultConfig :: String -> LoggerConfig logDefaultConfig n = LoggerConfig { lcName = n , lcPriority = DEBUG , lcHandler = LogToErr , lcFormatter = LogFmtNull } setLoggers :: YamlLight -> IO () setLoggers y = do -- it seems we need to explicitly create the root logger -- we set this to the lowest priority because we want the user to -- be able to set the priority on their loggers as low as they want updateGlobalLogger "" $ setLevel DEBUG . setHandlers noHandlers mapM_ setGeniHandler $ fromMaybe [globalDefault] (loggerConfig y) where noHandlers :: [GenericHandler ()] noHandlers = [] globalDefault = (logDefaultConfig "NLP.GenI") { lcPriority = INFO } setGeniHandler :: LoggerConfig -> IO () setGeniHandler lc = do h <- flip setFormatter fmttr <$> handler (lcPriority lc) updateGlobalLogger (lcName lc) (setHandlers [h]) where handler = case lcHandler lc of LogToFile f -> fileHandler f LogToErr -> streamHandler stderr -- fmttr = case lcFormatter lc of LogFmtSimple str -> simpleLogFormatter str LogFmtNull -> nullFormatter instance Read LogTo where readsPrec _ (dropPrefix "stderr" -> ("", x)) = [ (LogToErr, x) ] readsPrec p (dropPrefix "file" -> ("", x)) = map (first LogToFile) (readsQuotedStringPrec p x) readsPrec _ _ = [] instance Read LogFmt where readsPrec _ (dropPrefix "null" -> ("", x)) = [ (LogFmtNull, x) ] readsPrec p (dropPrefix "simple" -> ("", x)) = map (first LogFmtSimple) (readsQuotedStringPrec p x) readsPrec _ _ = [] readsQuotedStringPrec :: Int -> String -> [ (String, String) ] readsQuotedStringPrec p x@(h:_) | isSpace h = case dropWhile isSpace x of xs@('"':_) -> readsPrec p xs (break isSpace -> y) | not (null (fst y)) -> [y] _ -> [] readsQuotedStringPrec _ _ = [] loggerConfig :: YamlLight -> Maybe [LoggerConfig] loggerConfig yaml = lookupYL "logging" yaml >>= unSeq >>= mapM unMap >>= mapM readOne where readOne :: Map.Map YamlLight YamlLight -> Maybe LoggerConfig readOne m = do let name = fromMaybe "NLP.GenI" (get Just "name" m) return $ updater "level" m (\x l -> l { lcPriority = x }) . updater "handler" m (\x l -> l { lcHandler = x }) . updater "format" m (\x l -> l { lcFormatter = x }) $ logDefaultConfig name updater str m fn = maybe id fn (get maybeRead str m) get f x m = Map.lookup x m >>= unStr >>= (f . BC.unpack) instance IsString YamlLight where fromString = YStr . fromString -- ---------------------------------------------------------------------- -- -- ---------------------------------------------------------------------- singleton :: a -> [a] singleton = pure maybeRead :: Read a => String -> Maybe a maybeRead s = case reads s of [(x, rest)] | all isSpace rest -> Just x _ -> Nothing dropPrefix :: Eq a => [a] -> [a] -> ([a],[a]) dropPrefix (x:xs) (y:ys) | x == y = dropPrefix xs ys dropPrefix left right = (left,right)