pax_global_header00006660000000000000000000000064130533361160014513gustar00rootroot0000000000000052 comment=bf61906d3a2497ba4f3245780ece974526e0964b curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/000077500000000000000000000000001305333611600212305ustar00rootroot00000000000000curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/.gitignore000066400000000000000000000001531305333611600232170ustar00rootroot00000000000000# intermediate files *~ .curry Curry_Main_Goal.curry dist *.cabal AllLibraries.curry # documentation CDOC curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/AbstractCurry/000077500000000000000000000000001305333611600240205ustar00rootroot00000000000000curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/AbstractCurry/Build.curry000066400000000000000000000167311305333611600261550ustar00rootroot00000000000000------------------------------------------------------------------------ --- This library provides some useful operations to write programs --- that generate AbstractCurry programs in a more compact and readable way. --- --- @version February 2016 --- @category meta ------------------------------------------------------------------------ module AbstractCurry.Build where import AbstractCurry.Types infixr 9 ~> ------------------------------------------------------------------------ -- Goodies to construct type expressions --- A function type. (~>) :: CTypeExpr -> CTypeExpr -> CTypeExpr t1 ~> t2 = CFuncType t1 t2 --- A base type. baseType :: QName -> CTypeExpr baseType t = CTCons t [] --- Constructs a list type from an element type. listType :: CTypeExpr -> CTypeExpr listType a = CTCons (pre "[]") [a] --- Constructs a tuple type from list of component types. tupleType :: [CTypeExpr] -> CTypeExpr tupleType ts | l==0 = baseType (pre "()") | l==1 = head ts | otherwise = CTCons (pre ('(' : take (l-1) (repeat ',') ++ ")")) ts where l = length ts --- Constructs an IO type from a type. ioType :: CTypeExpr -> CTypeExpr ioType a = CTCons (pre "IO") [a] --- Constructs a Maybe type from element type. maybeType :: CTypeExpr -> CTypeExpr maybeType a = CTCons (pre "Maybe") [a] --- The type expression of the String type. stringType :: CTypeExpr stringType = baseType (pre "String") --- The type expression of the Int type. intType :: CTypeExpr intType = baseType (pre "Int") --- The type expression of the Float type. floatType :: CTypeExpr floatType = baseType (pre "Float") --- The type expression of the Bool type. boolType :: CTypeExpr boolType = baseType (pre "Bool") --- The type expression of the Char type. charType :: CTypeExpr charType = baseType (pre "Char") --- The type expression of the unit type. unitType :: CTypeExpr unitType = baseType (pre "()") --- The type expression of the Time.CalendarTime type. dateType :: CTypeExpr dateType = baseType ("Time", "CalendarTime") ------------------------------------------------------------------------ -- Goodies to construct function declarations --- Constructs a function declaration from a given qualified function name, --- arity, visibility, type expression and list of defining rules. cfunc :: QName -> Int -> CVisibility -> CTypeExpr -> [CRule] -> CFuncDecl cfunc = CFunc --- Constructs a function declaration from a given comment, --- qualified function name, --- arity, visibility, type expression and list of defining rules. cmtfunc :: String -> QName -> Int -> CVisibility -> CTypeExpr -> [CRule] -> CFuncDecl cmtfunc = CmtFunc --- Constructs a simple rule with a pattern list and an --- unconditional right-hand side. simpleRule :: [CPattern] -> CExpr -> CRule simpleRule pats rhs = CRule pats (CSimpleRhs rhs []) --- Constructs a simple rule with a pattern list, an --- unconditional right-hand side, and local declarations. simpleRuleWithLocals :: [CPattern] -> CExpr -> [CLocalDecl] -> CRule simpleRuleWithLocals pats rhs ldecls = CRule pats (CSimpleRhs rhs ldecls) --- Constructs a rule with a possibly guarded right-hand side --- and local declarations. --- A simple right-hand side is constructed if there is only one --- `True` condition. guardedRule :: [CPattern] -> [(CExpr,CExpr)] -> [CLocalDecl] -> CRule guardedRule pats gs ldecls | length gs == 1 && fst (head gs) == CSymbol (pre "True") = CRule pats (CSimpleRhs (snd (head gs)) ldecls) | otherwise = CRule pats (CGuardedRhs gs ldecls) --- Constructs a guarded expression with the trivial guard. noGuard :: CExpr -> (CExpr, CExpr) noGuard e = (CSymbol (pre "True"), e) ------------------------------------------------------------------------ -- Goodies to construct expressions and patterns --- An application of a qualified function name to a list of arguments. applyF :: QName -> [CExpr] -> CExpr applyF f es = foldl CApply (CSymbol f) es --- An application of an expression to a list of arguments. applyE :: CExpr -> [CExpr] -> CExpr applyE f args = foldl CApply f args --- A constant, i.e., an application without arguments. constF :: QName -> CExpr constF f = applyF f [] --- An application of a variable to a list of arguments. applyV :: CVarIName -> [CExpr] -> CExpr applyV v es = foldl CApply (CVar v) es -- Applies the Just constructor to an AbstractCurry expression. applyJust :: CExpr -> CExpr applyJust a = applyF (pre "Just") [a] -- Applies the maybe function to three AbstractCurry expressions. applyMaybe :: CExpr -> CExpr -> CExpr -> CExpr applyMaybe a1 a2 a3 = applyF (pre "maybe") [a1,a2,a3] --- Constructs a tuple expression from list of component expressions. tupleExpr :: [CExpr] -> CExpr tupleExpr es | l==0 = constF (pre "()") | l==1 = head es | otherwise = applyF (pre ('(' : take (l-1) (repeat ',') ++ ")")) es where l = length es -- Constructs a let declaration (with possibly empty local delcarations). letExpr :: [CLocalDecl] -> CExpr -> CExpr letExpr locals cexp = if null locals then cexp else CLetDecl locals cexp --- Constructs from a pattern and an expression a branch for a case expression. cBranch :: CPattern -> CExpr -> (CPattern, CRhs) cBranch pattern exp = (pattern, CSimpleRhs exp []) --- Constructs a tuple pattern from list of component patterns. tuplePattern :: [CPattern] -> CPattern tuplePattern ps | l==0 = CPComb (pre "()") [] | l==1 = head ps | otherwise = CPComb (pre ('(' : take (l-1) (repeat ',') ++ ")")) ps where l = length ps --- Constructs, for given n, a list of n PVars starting from 0. pVars :: Int -> [CPattern] pVars n = [CPVar (i,"x"++show i) | i<-[0..n-1]] --- Converts an integer into an AbstractCurry expression. pInt :: Int -> CPattern pInt x = CPLit (CIntc x) --- Converts a float into an AbstractCurry expression. pFloat :: Float -> CPattern pFloat x = CPLit (CFloatc x) --- Converts a character into a pattern. pChar :: Char -> CPattern pChar x = CPLit (CCharc x) --- Constructs an empty list pattern. pNil :: CPattern pNil = CPComb (pre "[]") [] --- Constructs a list pattern from list of component patterns. listPattern :: [CPattern] -> CPattern listPattern [] = pNil listPattern (p:ps) = CPComb (pre ":") [p, listPattern ps] --- Converts a string into a pattern representing this string. stringPattern :: String -> CPattern stringPattern = CPLit . CStringc --- Converts a list of AbstractCurry expressions into an --- AbstractCurry representation of this list. list2ac :: [CExpr] -> CExpr list2ac [] = constF (pre "[]") list2ac (c:cs) = applyF (pre ":") [c, list2ac cs] --- Converts an integer into an AbstractCurry expression. cInt :: Int -> CExpr cInt x = CLit (CIntc x) --- Converts a float into an AbstractCurry expression. cFloat :: Float -> CExpr cFloat x = CLit (CFloatc x) --- Converts a character into an AbstractCurry expression. cChar :: Char -> CExpr cChar x = CLit (CCharc x) --- Converts a string into an AbstractCurry represention of this string. string2ac :: String -> CExpr string2ac s = CLit (CStringc s) --- Converts an index i into a variable named xi. toVar :: Int -> CExpr toVar i = CVar (1,"x"++show i) --- Converts a string into a variable with index 1. cvar :: String -> CExpr cvar s = CVar (1,s) --- Converts a string into a pattern variable with index 1. cpvar :: String -> CPattern cpvar s = CPVar (1,s) --- Converts a string into a type variable with index 1. ctvar :: String -> CTypeExpr ctvar s = CTVar (1,s) ------------------------------------------------------------------------ curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/AbstractCurry/Files.curry000066400000000000000000000225701305333611600261560ustar00rootroot00000000000000-- --------------------------------------------------------------------------- --- This library defines various I/O actions to read Curry programs and --- transform them into the AbstractCurry representation and to write --- AbstractCurry files. --- --- Assumption: an abstract Curry program is stored in file with --- extension `.acy` in the subdirectory `.curry` --- --- @author Michael Hanus, Bjoern Peemoeller --- @version October 2015 --- @category meta -- --------------------------------------------------------------------------- module AbstractCurry.Files where import AbstractCurry.Select (imports) import AbstractCurry.Types import Char (isSpace) import Directory (doesFileExist, getModificationTime) import Distribution import FileGoodies (getFileInPath, lookupFileInPath) import FilePath (takeFileName, (), (<.>)) import Maybe (isNothing) import ReadShowTerm -- --------------------------------------------------------------------------- --- I/O action which parses a Curry program and returns the corresponding --- typed Abstract Curry program. --- Thus, the argument is the file name without suffix ".curry" --- or ".lcurry") and the result is a Curry term representing this --- program. readCurry :: String -> IO CurryProg readCurry prog = readCurryWithParseOptions prog (setQuiet True defaultParams) --- Read an AbstractCurry file with all its imports. --- @param modname - Module name or file name of Curry module --- @return a list of curry programs, having the AbstractCurry file as head. readCurryWithImports :: String -> IO [CurryProg] readCurryWithImports modname = collect [] [modname] where collect _ [] = return [] collect imported (m:ms) | m `elem` imported = collect imported ms | otherwise = do p <- readCurry m ps <- collect (m:imported) (ms ++ imports p) return (p:ps) tryReadCurryWithImports :: String -> IO (Either [String] [CurryProg]) tryReadCurryWithImports modname = collect [] [modname] where collect _ [] = return (Right []) collect imported (m:ms) | m `elem` imported = collect imported ms | otherwise = do eProg <- tryReadCurryFile m case eProg of Left err -> return (Left [err]) Right prog@(CurryProg _ is _ _ _) -> do results <- collect (m:imported) (ms ++ is) return (either Left (Right . (prog :)) results) tryReadCurryFile :: String -> IO (Either String CurryProg) tryReadCurryFile m = do mbSrc <- lookupModuleSourceInLoadPath m case mbSrc of Nothing -> cancel $ "Source module '" ++ m ++ "' not found" Just (_,srcFile) -> do callFrontendWithParams ACY (setQuiet True defaultParams) m mbFn <- getLoadPathForModule m >>= lookupFileInPath (abstractCurryFileName m) [""] case mbFn of Nothing -> cancel $ "AbstractCurry module '" ++ m ++ "' not found" Just fn -> do ctime <- getModificationTime srcFile ftime <- getModificationTime fn if ctime > ftime then cancel $ "Source file '" ++ srcFile ++ "' is newer than AbstractCurry file '" ++ fn ++ "'" else do mbProg <- tryParse fn case mbProg of Left err -> cancel err Right p -> return (Right p) where cancel str = return (Left str) --- Try to parse an AbstractCurry file. --- @param fn - file name of AbstractCurry file tryParse :: String -> IO (Either String CurryProg) tryParse fn = do exists <- doesFileExist fn if not exists then cancel $ "AbstractCurry file '" ++ fn ++ "' does not exist" else do src <- readFile fn let (line1, lines) = break (=='\n') src if line1 /= "{- "++version++" -}" then cancel $ "Could not parse AbstractCurry file '" ++ fn ++ "': incompatible versions" else case readsUnqualifiedTerm ["AbstractCurry.Types","Prelude"] lines of [(p,tl)] | all isSpace tl -> return (Right p) _ -> cancel $ "Could not parse AbstractCurry file '" ++ fn ++ "': no parse" where cancel str = return (Left str) --- I/O action which parses a Curry program and returns the corresponding --- untyped Abstract Curry program. --- Thus, the argument is the file name without suffix ".curry" --- or ".lcurry") and the result is a Curry term representing this --- program. readUntypedCurry :: String -> IO CurryProg readUntypedCurry prog = readUntypedCurryWithParseOptions prog (setQuiet True defaultParams) --- I/O action which reads a typed Curry program from a file (with extension --- ".acy") with respect to some parser options. --- This I/O action is used by the standard action readCurry. --- It is currently predefined only in Curry2Prolog. --- @param progfile - the program file name (without suffix ".curry") --- @param options - parameters passed to the front end readCurryWithParseOptions :: String -> FrontendParams -> IO CurryProg readCurryWithParseOptions progname options = do let modname = takeFileName progname mbsrc <- lookupModuleSourceInLoadPath progname case mbsrc of Nothing -> do -- no source file, try to find AbstractCurry file in load path: loadpath <- getLoadPathForModule progname filename <- getFileInPath (abstractCurryFileName modname) [""] loadpath readAbstractCurryFile filename Just (dir,_) -> do callFrontendWithParams ACY options progname readAbstractCurryFile (abstractCurryFileName (dir modname)) --- I/O action which reads an untyped Curry program from a file (with extension --- ".uacy") with respect to some parser options. For more details --- see function 'readCurryWithParseOptions' readUntypedCurryWithParseOptions :: String -> FrontendParams -> IO CurryProg readUntypedCurryWithParseOptions progname options = do let modname = takeFileName progname mbsrc <- lookupModuleSourceInLoadPath progname case mbsrc of Nothing -> do -- no source file, try to find AbstractCurry file in load path: loadpath <- getLoadPathForModule progname filename <- getFileInPath (untypedAbstractCurryFileName modname) [""] loadpath readAbstractCurryFile filename Just (dir,_) -> do callFrontendWithParams UACY options progname readAbstractCurryFile (untypedAbstractCurryFileName (dir modname)) --- Transforms a name of a Curry program (with or without suffix ".curry" --- or ".lcurry") into the name of the file containing the --- corresponding AbstractCurry program. abstractCurryFileName :: String -> String abstractCurryFileName prog = inCurrySubdir (stripCurrySuffix prog) <.> "acy" --- Transforms a name of a Curry program (with or without suffix ".curry" --- or ".lcurry") into the name of the file containing the --- corresponding untyped AbstractCurry program. untypedAbstractCurryFileName :: String -> String untypedAbstractCurryFileName prog = inCurrySubdir (stripCurrySuffix prog) <.> "uacy" --- I/O action which reads an AbstractCurry program from a file in ".acy" --- format. In contrast to readCurry, this action does not parse --- a source program. Thus, the argument must be the name of an existing --- file (with suffix ".acy") containing an AbstractCurry program in ".acy" --- format and the result is a Curry term representing this program. --- It is currently predefined only in Curry2Prolog. readAbstractCurryFile :: String -> IO CurryProg readAbstractCurryFile filename = do exacy <- doesFileExist filename if exacy then readExistingACY filename else do let subdirfilename = inCurrySubdir filename exdiracy <- doesFileExist subdirfilename if exdiracy then readExistingACY subdirfilename else error ("EXISTENCE ERROR: AbstractCurry file '"++filename++ "' does not exist") where readExistingACY fname = do filecontents <- readFile fname let (line1,lines) = break (=='\n') filecontents if line1 == "{- "++version++" -}" then return (readUnqualifiedTerm ["AbstractCurry.Types","Prelude"] lines) else error $ "AbstractCurry: incompatible file found: "++fname --- Tries to read an AbstractCurry file and returns --- --- * Left err , where err specifies the error occurred --- * Right prog, where prog is the AbstractCurry program tryReadACYFile :: String -> IO (Maybe CurryProg) tryReadACYFile fn = do exists <- doesFileExist fn if exists then tryRead fn else do let fn' = inCurrySubdir fn exists' <- doesFileExist fn' if exists' then tryRead fn' else cancel where tryRead file = do src <- readFile file let (line1,lines) = break (=='\n') src if line1 /= "{- "++version++" -}" then error $ "AbstractCurry: incompatible file found: "++fn else case readsUnqualifiedTerm ["AbstractCurry.Types","Prelude"] lines of [] -> cancel [(p,tl)] -> if all isSpace tl then return $ Just p else cancel _ -> cancel cancel = return Nothing --- Writes an AbstractCurry program into a file in ".acy" format. --- The first argument must be the name of the target file --- (with suffix ".acy"). writeAbstractCurryFile :: String -> CurryProg -> IO () writeAbstractCurryFile file prog = writeFile file (showTerm prog) ------------------------------------------------------------------------------ curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/AbstractCurry/Pretty.curry000066400000000000000000001237251305333611600264070ustar00rootroot00000000000000--- -------------------------------------------------------------------------- --- Pretty-printing of AbstractCurry. --- --- This library provides a pretty-printer for AbstractCurry modules. --- --- @author Yannik Potdevin (with changes by Michael Hanus) --- @version March 2016 --- @category meta --- -------------------------------------------------------------------------- module AbstractCurry.Pretty ( Qualification, Options, LayoutChoice(..) , defaultOptions , setPageWith, setIndentWith , setNoQualification, setFullQualification, setImportQualification , setOnDemandQualification , setModName, setLayoutChoice , showCProg, prettyCurryProg, ppCurryProg , ppMName, ppExports, ppImports , ppCOpDecl, ppCTypeDecl, ppCFuncDecl, ppCFuncDeclWithoutSig, ppCRhs , ppCFuncSignature, ppCTypeExpr, ppCRules, ppCRule , ppCPattern, ppCLiteral, ppCExpr , ppCStatement, ppQFunc, ppFunc, ppQType, ppType) where import Pretty hiding ( list, listSpaced, tupled, tupledSpaced, set , setSpaced ) import AbstractCurry.Select hiding (varsOfLDecl, varsOfFDecl, varsOfStat) import AbstractCurry.Types import AbstractCurry.Transform (typesOfCurryProg, funcsOfCurryProg) import Function (on) import List (partition, union, scanl, last, nub, (\\)) import Maybe (isJust, fromJust) type Collection a = [a] data Qualification = Full -- ^ Fully qualify every identifier, including those of the -- processed module and Prelude. | Imports -- ^ Fully qualify external identifiers, do not qualify local -- identifiers and those of Prelude. | OnDemand -- ^ Fully qualify only identifiers which need to be. | None -- ^ Do not qualify any function. --- The choice for a generally preferred layout. --- @cons PreferNestedLayout - prefer a layout where the arguments of --- long expressions are vertically aligned --- @cons PreferFilledLayout - prefer a layout where the arguments of --- long expressions are filled as long as possible --- into one line data LayoutChoice = PreferNestedLayout -- ^ Prefer -- a f a -- + b respectively b -- + ... c -- if an expression does not fit the page | PreferFilledLayout -- ^ Prefer -- a + b f a b -- + c + d respectively c d -- if an expression does not fit the page data Options = Options { pageWidth :: Int , indentationWidth :: Int , qualification :: Qualification , moduleName :: String {- Debugging flag (show signature of local functions or not). -} , showLocalSigs :: Bool , layoutChoice :: LayoutChoice {- A collection of all to this module visible types (i.e. all imported [prelude too] and self defined types) -- used to determine how to qualify, if Qualification`OnDemand` was chosen. -} , visibleTypes :: Collection QName {- A collection of all to this module visible functions and constructors (i.e. all imported [prelude too] and self defined ones) -- used to determine how to qualify, if Qualification `OnDemand` was chosen. -} , visibleFunctions :: Collection QName {- A collection of currently visible (depending on context) variables. Used to determine how to qualify, if Qualification `OnDemand` was chosen. -} , visibleVariables :: Collection CVarIName } --- The default options to pretty print a module. These are: --- * page width: 78 characters --- * indentation width: 2 characters --- * qualification method: qualify all imported names (except prelude names) --- * layout choice: prefer nested layout (see 'LayoutChoice') --- These options can be changed by corresponding setters --- ('setPageWith', 'setIndentWith', `set...Qualification`, 'setLayoutChoice'). --- --- Note: If these default options are used for pretty-print operations --- other than 'prettyCurryProg' or 'ppCurryProg', then one has to set --- the current module name explicitly by 'setModName'! defaultOptions :: Options defaultOptions = Options { pageWidth = 78 , indentationWidth = 2 , qualification = Imports , moduleName = "" , showLocalSigs = False , layoutChoice = PreferNestedLayout , visibleTypes = emptyCol , visibleFunctions = emptyCol , visibleVariables = emptyCol } --- Sets the page width of the pretty printer options. setPageWith :: Int -> Options -> Options setPageWith pw o = o { pageWidth = pw } --- Sets the indentation width of the pretty printer options. setIndentWith :: Int -> Options -> Options setIndentWith iw o = o { indentationWidth = iw } --- Sets the qualification method to be used to print identifiers to --- "import qualification" (which is the default). --- In this case, all identifiers imported from other modules (except --- for the identifiers of the prelude) are fully qualified. setImportQualification :: Options -> Options setImportQualification o = o { qualification = Imports } --- Sets the qualification method to be used to print identifiers to --- "unqualified". --- In this case, no identifiers is printed with its module qualifier. --- This might lead to name conflicts or unintended references --- if some identifiers in the pretty-printed module are in conflict --- with imported identifiers. setNoQualification :: Options -> Options setNoQualification o = o { qualification = None } --- Sets the qualification method to be used to print identifiers to --- "fully qualified". --- In this case, every identifiers, including those of the processed module --- and the prelude, are fully qualified. setFullQualification :: Options -> Options setFullQualification o = o { qualification = Full } --- Sets the qualification method to be used to print identifiers to --- "qualification on demand". --- In this case, an identifier is qualified only if it is necessary --- to avoid a name conflict, e.g., if a local identifier has the same --- names as an imported identifier. Since it is necessary to know --- the names of all identifiers defined in the current module (to be pretty --- printed) and imported from other modules, the first argument --- is the list of modules consisting of the current module and --- all imported modules (including the prelude). --- The current module must always be the head of this list. setOnDemandQualification :: [CurryProg] -> Options -> Options setOnDemandQualification mods o = setRelatedMods mods (o { qualification = OnDemand }) --- Sets the name of the current module in the pretty printer options. setModName :: MName -> Options -> Options setModName m o = o { moduleName = m } --- Sets the preferred layout in the pretty printer options. setLayoutChoice :: LayoutChoice -> Options -> Options setLayoutChoice lc o = o { layoutChoice = lc } --- Sets the related modules in the pretty printer options. See 'options' to --- read a specification of "related modules". setRelatedMods :: [CurryProg] -> Options -> Options setRelatedMods [] o = o setRelatedMods (currentMod:imports) o = o { visibleTypes = vts, visibleFunctions = vfs } where vts = fromList $ map typeName (types currentMod) ++ collect publicTypeNames vfs = fromList $ concat [ map funcName $ functions currentMod , collect publicFuncNames , map consName $ constructors currentMod , collect publicConsNames ] collect proj = foldr union [] $ map proj imports --- precedence of top level (pattern or application) context -- lowest tlPrec :: Int tlPrec = 0 --- precedence of infix (pattern or application) context infAppPrec :: Int infAppPrec = 1 --- precedence of standard prefix (pattern or application) context prefAppPrec :: Int prefAppPrec = 2 --- precedence of atoms (variables, literals, tuples, lists ...) highestPrec :: Int highestPrec = 3 --- Shows a pretty formatted version of an abstract Curry Program. --- The options for pretty-printing are the 'defaultOptions' (and therefore the --- restrictions mentioned there apply here too). --- @param prog - a curry prog --- @return a string, which represents the input program `prog` showCProg :: CurryProg -> String showCProg = prettyCurryProg defaultOptions --- Pretty-print the document generated by 'ppCurryProg', using the page width --- specified by given options. prettyCurryProg :: Options -> CurryProg -> String prettyCurryProg opts cprog = pretty (pageWidth opts) $ ppCurryProg opts cprog --- Pretty-print a CurryProg (the representation of a program, written in Curry, --- using AbstractCurry) according to given options. --- This function will overwrite the module name given by options --- with the name specified as the first component of `CurryProg`. --- The list of imported modules is extended to all modules mentioned --- in the program if qualified pretty printing is used. --- This is necessary to avoid errors w.r.t. names re-exported by modules. ppCurryProg :: Options -> CurryProg -> Doc ppCurryProg opts cprog@(CurryProg m ms ts fs os) = vsepBlank [ (nest' opts' $ sep [ text "module" <+> ppMName m, ppExports opts' ts fs]) where_ , ppImports opts' allImports , vcatMap (ppCOpDecl opts') os , vsepBlankMap (ppCTypeDecl opts') ts , vsepBlankMap (ppCFuncDecl opts') fs ] where opts' = opts { moduleName = m } allModNames = filter (not . null) (union (nub (map fst (typesOfCurryProg cprog))) (nub (map fst (funcsOfCurryProg cprog)))) allImports = if qualification opts == None then ms else nub (ms ++ allModNames) \\ [m] --- Pretty-print a module name (just a string). ppMName :: MName -> Doc ppMName = text --- Pretty-print exports, i.e. all type and function declarations which are --- public. --- extract the type and function declarations which are public and gather their --- qualified names in a list. ppExports :: Options -> [CTypeDecl] -> [CFuncDecl] -> Doc ppExports opts ts fs | null pubTs && null pubFs = parens empty -- nothing is exported | null privTs && null privFs && null privCs = empty -- everything is exported | otherwise = filledTupledSpaced $ map tDeclToDoc pubTs ++ map fDeclToDoc pubFs where (pubTs, privTs) = partition isPublicTypeDecl ts (pubFs, privFs) = partition isPublicFuncDecl fs privCs = filter ((== Private) . consVis) . concatMap typeCons $ ts isPublicTypeDecl = (== Public) . typeVis isPublicFuncDecl = (== Public) . funcVis tDeclToDoc = on' (<>) (ppQTypeParsIfInfix opts . typeName) (ppConsExports opts . typeCons) fDeclToDoc = ppQFuncParsIfInfix opts . funcName -- internal use only ppConsExports :: Options -> [CConsDecl] -> Doc ppConsExports opts cDecls | null pubCs = empty | null privCs = parens $ dot <> dot | otherwise = filledTupled $ map cDeclToDoc pubCs where (pubCs, privCs) = partition isPublicConsDecl cDecls isPublicConsDecl = (== Public) . consVis cDeclToDoc = ppQFuncParsIfInfix opts . consName --- Pretty-print imports (list of module names) by prepending the word "import" --- to the module name. If the qualification mode is 'Imports' or 'Full', --- then the imports are declared as `qualified`. ppImports :: Options -> [MName] -> Doc ppImports opts imps = vcatMap (\m -> text importmode <+> ppMName m) (filter (/= "Prelude") imps) where importmode = if qualification opts `elem` [Imports,Full] then "import qualified" else "import" --- Pretty-print operator precedence declarations. ppCOpDecl :: Options -> COpDecl -> Doc ppCOpDecl _ (COp qn fix p) = hsep [ppCFixity fix, int p, genericPPName (bquotesIf . not . isInfixId) qn] --- Pretty-print the fixity of a function. ppCFixity :: CFixity -> Doc ppCFixity CInfixOp = text "infix" ppCFixity CInfixlOp = text "infixl" ppCFixity CInfixrOp = text "infixr" --- Pretty-print type declarations, like `data ... = ...`, `type ... = ...` or --- `newtype ... = ...`. ppCTypeDecl :: Options -> CTypeDecl -> Doc ppCTypeDecl opts (CType qn _ tVars cDecls) = hsep [ text "data", ppType qn, ppCTVarINames opts tVars , if null cDecls then empty else ppCConsDecls opts cDecls] ppCTypeDecl opts (CTypeSyn qn _ tVars tExp) = hsep [ text "type", ppType qn, ppCTVarINames opts tVars , align $ equals <+> ppCTypeExpr opts tExp] ppCTypeDecl opts (CNewType qn _ tVars cDecl) = hsep [ text "newtype", ppType qn, ppCTVarINames opts tVars, equals , ppCConsDecl opts cDecl] --- Pretty-print a list of constructor declarations, including the `=` sign. ppCConsDecls :: Options -> [CConsDecl] -> Doc ppCConsDecls opts cDecls = align . sep $ [equals <+> ppCConsDecl opts (head cDecls)] ++ map ((bar <+>) . (ppCConsDecl opts)) (tail cDecls) --- Pretty-print a constructor declaration. ppCConsDecl :: Options -> CConsDecl -> Doc ppCConsDecl opts (CCons qn _ tExps ) = ppFunc qn <+> hsepMap (ppCTypeExpr' 2 opts) tExps ppCConsDecl opts (CRecord qn _ fDecls) = ppFunc qn <+> alignedSetSpaced (map (ppCFieldDecl opts) fDecls) --- Pretty-print a record field declaration (`field :: type`). ppCFieldDecl :: Options -> CFieldDecl -> Doc ppCFieldDecl opts (CField qn _ tExp) = hsep [ ppFunc qn , doubleColon , ppCTypeExpr opts tExp ] --- Pretty-print a function declaration. ppCFuncDecl :: Options -> CFuncDecl -> Doc ppCFuncDecl opts fDecl@(CFunc qn _ _ tExp _) = ppCFuncSignature opts qn tExp <$!$> ppCFuncDeclWithoutSig opts fDecl ppCFuncDecl opts (CmtFunc cmt qn a v tExp rs) = vsepMap (text . ("--- " ++)) (lines cmt) <$!$> ppCFuncDecl opts (CFunc qn a v tExp rs) --- Pretty-print a function declaration without signature. ppCFuncDeclWithoutSig :: Options -> CFuncDecl -> Doc ppCFuncDeclWithoutSig opts fDecl@(CFunc qn _ _ _ rs) = ppCRules funcDeclOpts qn rs where funcDeclOpts = addFuncNamesToOpts (funcNamesOfFDecl fDecl) opts ppCFuncDeclWithoutSig opts (CmtFunc cmt qn a v tExp rs) = vsepMap (text . ("--- " ++)) (lines cmt) <$!$> ppCFuncDeclWithoutSig opts (CFunc qn a v tExp rs) --- Pretty-print a function signature according to given options. ppCFuncSignature :: Options -> QName -> CTypeExpr -> Doc ppCFuncSignature opts qn tExp | isUntyped tExp = empty | otherwise = nest' opts $ sep [ genericPPName parsIfInfix qn , align $ doubleColon <+> ppCTypeExpr opts tExp ] where isUntyped te = te == CTCons (pre "untyped") [] --- Pretty-print a type expression. ppCTypeExpr :: Options -> CTypeExpr -> Doc ppCTypeExpr = ppCTypeExpr' tlPrec -- Internal use only: Pretty-print a type expression and make use of supplied -- precedence context. The supplied number represents the precedence of the -- enclosing expression. Higher values mean more precedence, so if the nested -- expression has lower precedence than the enclosing expression, the nested one -- has to be enclosed in parentheses. ppCTypeExpr' :: Int -> Options -> CTypeExpr -> Doc ppCTypeExpr' _ opts (CTVar tvar) = ppCTVarIName opts tvar ppCTypeExpr' p opts (CFuncType tExp1 tExp2) = parensIf (p > tlPrec) $ sep [ ppCTypeExpr' 1 opts tExp1, rarrow <+> ppCTypeExpr opts tExp2] ppCTypeExpr' p opts (CTCons qn tExps) | null tExps = ppQType opts qn | isListCons qn = brackets . (ppCTypeExpr opts) . head $ tExps -- assume singleton | isTupleCons qn = alignedTupled $ map (ppCTypeExpr opts) tExps | otherwise = parensIf (p >= 2) $ ppQType opts qn <+> hsepMap (ppCTypeExpr' 2 opts) tExps --- Pretty-print a list of type variables horizontally separating them by `space`. ppCTVarINames :: Options -> [CTVarIName] -> Doc ppCTVarINames opts = hsepMap (ppCTVarIName opts) --- Pretty-print a type variable (currently the Int is ignored). ppCTVarIName :: Options -> CTVarIName -> Doc ppCTVarIName _ (_, tvar) = text tvar --- Pretty-print a list of function rules, concatenated vertically. ppCRules :: Options -> QName -> [CRule] -> Doc ppCRules opts qn rs | null rs = genericPPName parsIfInfix qn <+> text "external" | otherwise = vcatMap (ppCRule opts qn) rs --- Pretty-print a rule of a function. Given a function --- `f x y = x * y`, then `x y = x * y` is a rule consisting of `x y` as list of --- patterns and `x * y` as right hand side. ppCRule :: Options -> QName -> CRule -> Doc ppCRule opts qn rule@(CRule ps rhs) = (nest' opts $ sep [ ppCPattern opts (CPComb qn ps) {- exploit similarity between left hand side of rule and constructor pattern -} <+> (case rhs of CSimpleRhs _ _ -> equals CGuardedRhs _ _ -> empty ) , ppFuncRhs rhsOpts rhs ] ) $$ if null lDecls then empty else indent' opts $ ppWhereDecl whereOpts lDecls where lDecls = ldeclsOfRule rule whereOpts = addVarsToOpts (concatMap varsOfPat ps) opts rhsOpts = last $ optsWithIncreasingNamespaces varsOfLDecl funcNamesOfLDecl lDecls whereOpts --- Pretty-print a pattern expression. ppCPattern :: Options -> CPattern -> Doc ppCPattern = ppCPattern' tlPrec -- Internal use only: Pretty-print a pattern expression and make use of supplied -- precedence context. The supplied number represents the precedence of the -- enclosing pattern. Higher values mean more precedence, so if the nested -- pattern has lower precedence than the enclosing pattern, the nested one has -- to be enclosed in parentheses. ppCPattern' :: Int -> Options -> CPattern -> Doc ppCPattern' _ opts (CPVar pvar) = ppCVarIName opts pvar ppCPattern' _ opts (CPLit lit ) = ppCLiteral opts lit ppCPattern' p opts pat@(CPComb qn ps) | null ps = parsIfInfix qn qnDoc | isApp qn = parensIf (p >= prefAppPrec) $ ppCPattern' infAppPrec opts (ps !! 0) <+> ppCPattern' prefAppPrec opts (ps !! 1) | isTupleCons qn = filledTupled . map (ppCPattern opts) $ ps | isFinLis pat = let ps' = fromJust $ extractFiniteListPattern pat in alignedList . map (ppCPattern opts) $ ps' | isInfixId qn = case ps of [l, r] -> parensIf (p >= infAppPrec) $ hsep [ ppCPattern' p' opts l, qnDoc , ppCPattern' p' opts r ] _ -> prefixApp | otherwise = prefixApp where qnDoc = ppQFunc opts qn isApp = (== ("Prelude", "apply")) p' = if isInfixId qn then infAppPrec else prefAppPrec prefixApp = parensIf (p >= prefAppPrec) . nest' opts $ sep [ parsIfInfix qn qnDoc , align . (case layoutChoice opts of PreferFilledLayout -> fillSep PreferNestedLayout -> sep) . map (ppCPattern' p' opts) $ ps ] isFinLis = isJust . extractFiniteListPattern ppCPattern' _ opts (CPAs pvar p) = hcat [ppCVarIName opts pvar, at, ppCPattern' highestPrec opts p] ppCPattern' p opts (CPFuncComb qn ps) = ppCPattern' p opts (CPComb qn ps) ppCPattern' _ opts (CPLazy p ) = tilde <> ppCPattern' highestPrec opts p ppCPattern' _ opts (CPRecord qn rps) = ppQFunc opts qn <+> alignedSetSpaced (map (ppCFieldPattern opts) rps) --- Pretty-print a pattern variable (currently the Int is ignored). ppCVarIName :: Options -> CVarIName -> Doc ppCVarIName _ (_, pvar) = text pvar --- Pretty-print given literal (Int, Float, ...). ppCLiteral :: Options -> CLiteral -> Doc ppCLiteral _ (CIntc i) = int i ppCLiteral _ (CFloatc f) = float f ppCLiteral _ (CCharc c) = text $ show c ppCLiteral _ (CStringc s) | null s = text "\"\"" -- necessary for pakcs | otherwise = text $ show s --- Pretty-print a record pattern ppCFieldPattern :: Options -> CField CPattern -> Doc ppCFieldPattern opts (qn, p) = ppQFunc opts qn <+> equals <+> ppCPattern opts p --- Pretty-print the right hand side of a rule (or case expression), including --- the d sign, where `d` is the relation (as doc) between the left hand side --- and the right hand side -- usually this is one of `=`, `->`. --- If the right hand side contains local declarations, they will be pretty --- printed too, further indented. ppCRhs :: Doc -> Options -> CRhs -> Doc ppCRhs d opts rhs = case rhs of CSimpleRhs exp lDecls -> (nest' opts $ sep [d, ppCExpr (expAndGuardOpts lDecls) exp]) $$ maybePPlDecls lDecls CGuardedRhs conds lDecls -> ppCGuardedRhs (expAndGuardOpts lDecls) d conds $$ maybePPlDecls lDecls where expAndGuardOpts ls = last $ optsWithIncreasingNamespaces varsOfLDecl funcNamesOfLDecl ls opts maybePPlDecls ls = if null ls then empty else indent' opts (ppWhereDecl opts ls) --- Like 'ppCRhs', but do not pretty-print local declarations. --- Instead give caller the choice how to handle the declarations. For example --- the function 'ppCRule' uses this to prevent local declarations from being --- further indented. ppFuncRhs :: Options -> CRhs -> Doc {- No further enrichment of options necessary -- it was done in 'ppCRule' -} ppFuncRhs opts (CSimpleRhs exp _) = ppCExpr opts exp ppFuncRhs opts (CGuardedRhs conds _) = ppCGuardedRhs opts equals conds ppCaseRhs :: Options -> CRhs -> Doc ppCaseRhs = ppCRhs rarrow --- Pretty-print guard, i.e. the `| cond d exp` part of a right hand side, where --- `d` is the relation (as doc) between `cond` and `exp` -- usually this is --- one of `=`, `->`. ppCGuardedRhs :: Options -> Doc -> [(CExpr, CExpr)] -> Doc ppCGuardedRhs opts d = align . vvsepMap ppCGuard where ppCGuard (e1, e2) = sep [ bar <+> ppCExpr opts e1 , d <+> ppCExpr opts e2 ] --- Pretty-print local declarations . If the second argument is `text "where"`, --- pretty-print a `where` block. If the second argument is `text "let"`, --- pretty-print a `let` block without `in`. ppCLocalDecls :: Options -> Doc -> [CLocalDecl] -> Doc ppCLocalDecls opts d lDecls = (d <+>) . align . vvsepMap (ppCLocalDecl lDeclOpts) $ lDecls where lDeclOpts = last $ optsWithIncreasingNamespaces varsOfLDecl funcNamesOfLDecl lDecls opts --- Pretty-print local declarations (the part that follows the `where` keyword). ppCLocalDecl :: Options -> CLocalDecl -> Doc ppCLocalDecl opts (CLocalFunc fDecl) = if showLocalSigs opts then ppCFuncDecl opts fDecl else ppCFuncDeclWithoutSig opts fDecl ppCLocalDecl opts (CLocalPat p rhs) = hsep [ ppCPattern opts p, ppCRhs equals rhsOpts rhs ] where rhsOpts = addVarsToOpts (varsOfPat p) opts ppCLocalDecl opts (CLocalVars pvars) = (<+> text "free") $ hsep $ punctuate comma $ map (ppCVarIName opts) pvars --- Pretty-print a `where` block, in which the word `where` stands alone in a --- single line, above the following declarations. ppWhereDecl :: Options -> [CLocalDecl] -> Doc ppWhereDecl opts lDecls = (where_ $$) . indent' opts . vvsepMap (ppCLocalDecl lDeclOpts) $ lDecls where lDeclOpts = last $ optsWithIncreasingNamespaces varsOfLDecl funcNamesOfLDecl lDecls opts --- Pretty-print a `let` block without `in`. In contrast to 'ppWhereDecl', the --- word `let` is in the same line as the first local declaration. ppLetDecl :: Options -> [CLocalDecl] -> Doc ppLetDecl opts = ppCLocalDecls opts (text "let") --- Pretty-print an expression. ppCExpr :: Options -> CExpr -> Doc ppCExpr = ppCExpr' tlPrec -- Internal use only: Pretty-print an expression and make use of supplied -- precedence context. The supplied number represents the precedence of the -- enclosing expression. Higher values mean more precedence, so if the nested -- expression has lower precedence than the enclosing expression, the nested one -- has to be enclosed in parentheses. ppCExpr' :: Int -> Options -> CExpr -> Doc ppCExpr' _ opts (CVar pvar) = ppCVarIName opts pvar ppCExpr' _ opts (CLit lit ) = ppCLiteral opts lit ppCExpr' _ opts (CSymbol qn ) = ppQFuncParsIfInfix opts qn ppCExpr' p opts app@(CApply f exp) | isITE app = parensIf (p > tlPrec) $ let (c, t, e) = fromJust $ extractITE app in text "if" <+> (align $ sep [ ppCExpr opts c , text "then" <+> ppCExpr opts t , text "else" <+> ppCExpr opts e]) | isTup app = let args = fromJust $ extractTuple app in alignedTupled (map (ppCExpr opts) args) | isFinLis app = let elems = fromJust $ extractFiniteListExp app in (case layoutChoice opts of PreferNestedLayout -> alignedList PreferFilledLayout -> filledList ) (map (ppCExpr opts) elems) | isInf app = parensIf (p >= infAppPrec) $ let (op, l, r) = fromJust $ extractInfix app in (case layoutChoice opts of PreferNestedLayout -> ppNestedWay PreferFilledLayout -> ppFilledWay) (ppCExpr' infAppPrec opts l) (ppQFunc opts op) (ppCExpr' infAppPrec opts r) | otherwise = parensIf (p >= prefAppPrec) $ (case layoutChoice opts of PreferNestedLayout -> ppNestedWay PreferFilledLayout -> ppFilledWay) (ppCExpr' infAppPrec opts f) empty (ppCExpr' prefAppPrec opts exp) where isITE = isJust . extractITE isInf = isJust . extractInfix isTup = isJust . extractTuple isFinLis = isJust . extractFiniteListExp ppNestedWay l sepa r = align . nest 1 $ sep [l, sepa <+> r] ppFilledWay l sepa r = nest 1 $ fillSep [l, sepa, r] ppCExpr' p opts (CLambda ps exp) = parensIf (p > tlPrec) . nest' opts $ sep [ backslash <> hsepMap (ppCPattern' prefAppPrec opts) ps <+> rarrow , ppCExpr expOpts exp] where expOpts = addVarsToOpts (concatMap varsOfPat ps) opts ppCExpr' p opts (CLetDecl lDecls exp) = parensIf (p > tlPrec) . align {- 'ppLetDecl' itself ensures the correct handling of opts -} $ sep [ ppLetDecl opts lDecls, text "in" <+> ppCExpr expOpts exp] where expOpts = last $ optsWithIncreasingNamespaces varsOfLDecl funcNamesOfLDecl lDecls opts ppCExpr' p opts (CDoExpr stms) = parensIf (p > tlPrec) $ text "do" <+> align (vvsep $ zipWith ppCStatement statOptsList stms) where statOptsList = optsWithIncreasingNamespaces varsOfStat funcNamesOfStat stms opts ppCExpr' _ opts (CListComp exp stms) = brackets $ hsep [ ppCExpr expOpts exp, bar , hsep $ punctuate (comma <> space) (zipWith ppCStatement statOptsList stms)] where expOpts = last statOptsList statOptsList = optsWithIncreasingNamespaces varsOfStat funcNamesOfStat stms opts ppCExpr' p opts (CCase cType exp cases) = parensIf (p > tlPrec) . align . nest' opts $ sep [ ppCCaseType cType <+> ppCExpr opts exp <+> text "of" , ppCases opts cases] ppCExpr' p opts (CTyped exp tExp) = parensIf (p > tlPrec) $ hsep [ppCExpr opts exp, doubleColon, ppCTypeExpr opts tExp] ppCExpr' _ opts (CRecConstr qn rFields) = ppQFunc opts qn <+> ppRecordFields opts rFields ppCExpr' p opts (CRecUpdate exp rFields) = ppCExpr' p opts exp <+> ppRecordFields opts rFields ppCStatement :: Options -> CStatement -> Doc ppCStatement opts (CSExpr exp ) = ppCExpr opts exp ppCStatement opts (CSPat pat exp) = ppCPattern opts pat <+> larrow <+> ppCExpr opts exp ppCStatement opts (CSLet lDecls ) = ppLetDecl opts lDecls --- Pretty-print `case`, `fcase` keywords. ppCCaseType :: CCaseType -> Doc ppCCaseType CRigid = text "case" ppCCaseType CFlex = text "fcase" --- Pretty-print a list of case expressions, i.e. the `p1 -> e1`,...,`pn -> en`, --- transitions, vertically aligned. ppCases :: Options -> [(CPattern, CRhs)] -> Doc ppCases opts = align . vvsepMap (ppCase opts) --- Pretty-print a case expression. ppCase :: Options -> (CPattern, CRhs) -> Doc ppCase opts (p, rhs) = ppCPattern opts p <+> ppCaseRhs rhsOpts rhs where rhsOpts = addVarsToOpts (varsOfPat p) opts --- Pretty-print record field assignments like this: --- { lab1 = exp1, ..., labn expn } --- if it fits the page, or --- { lab1 = exp1 --- , ... --- , labn = expn } --- otherwise. ppRecordFields :: Options -> [CField CExpr] -> Doc ppRecordFields opts = alignedSetSpaced . map (ppRecordField opts) --- Pretty-print a record field assignment (`fieldLabel = exp`). ppRecordField :: Options -> CField CExpr -> Doc ppRecordField opts (qn, exp) = ppQFunc opts qn <+> equals <+> ppCExpr opts exp --- Pretty-print a QName qualified according to given options. --- @param visNames - Depending on call, this is the namespace of visible types --- or of visible functions. Used to determine if `qn` is --- ambiguous, in case the qualification method 'OnDemand' was --- chosen --- @param visVars - The in current context visible variables. --- @param g - A doc tranformer used to manipulate (f.e. surround with --- parentheses) the QName, after it was (maybe) qualified. --- @param opts - The options to use. --- @param qn - The `QName` to pretty-print. --- @return A pretty-printed `QName`, maybe qualified (depending on settings). genericPPQName :: Collection QName -> Collection CVarIName -> (QName -> Doc -> Doc) -> Options -> QName -> Doc genericPPQName visNames visVars g opts qn@(m, f) | qnIsBuiltIn = name | null m = name -- assume local declaration | otherwise = case qualification opts of Full -> qName Imports -> if m == moduleName opts || m == "Prelude" then name else qName OnDemand -> if m == moduleName opts then name else odName -- at this point we know qn is imported None -> name where qnIsBuiltIn = or (map ($ qn) [ isUnitCons , isListCons , isTupleCons, isConsCons ]) name = g qn (text f) qName = g qn $ ppMName m <> dot <> text f odName = if isShadowed qn || isAmbiguous qn then qName else name isAmbiguous n = anyCol (on' (&&) (sameName n) (diffMod n)) visNames isShadowed n = anyCol (sameName n) visVars sameName :: (a, c) -> (b, c) -> Bool sameName = \(_,x) (_,y) -> x == y diffMod = (/=) `on` fst genericPPName :: (QName -> Doc -> Doc) -> QName -> Doc genericPPName f qn = f qn $ text . snd $ qn --- Pretty-print a function name or constructor name qualified according to --- given options. Use 'ppQType' or 'ppType' for pretty-printing type names. ppQFunc :: Options -> QName -> Doc ppQFunc opts = genericPPQName (visibleFunctions opts) (visibleVariables opts) (flip const) opts --- Like 'ppQFunc', but surround name with parentheses if it is an infix --- identifier. ppQFuncParsIfInfix :: Options -> QName -> Doc ppQFuncParsIfInfix opts = genericPPQName (visibleFunctions opts) (visibleVariables opts) parsIfInfix opts --- Pretty-print a function name or constructor name non-qualified. --- Use 'ppQType' or 'ppType' for pretty-printing type names. ppFunc :: QName -> Doc ppFunc = genericPPName (flip const) --- Pretty-print a type (`QName`) qualified according to given options. ppQType :: Options -> QName -> Doc ppQType opts = genericPPQName (visibleTypes opts) emptyCol (flip const) opts --- Like 'ppQType', but surround name with parentheses if it is an infix --- identifier. ppQTypeParsIfInfix :: Options -> QName -> Doc ppQTypeParsIfInfix opts = genericPPQName (visibleTypes opts) emptyCol parsIfInfix opts --- Pretty-print a type (`QName`) non-qualified. ppType :: QName -> Doc ppType = genericPPName (flip const) -- Helping function (diagnosis) --- Check whether an operator is an infix identifier. isInfixId :: QName -> Bool isInfixId = all (`elem` "~!@#$%^&*+-=<>:?./|\\") . snd --- Check whether an identifier represents the unit constructor isUnitCons :: QName -> Bool isUnitCons (_, i) = i == "()" --- Check whether an identifier represents the empty list constructor isListCons :: QName -> Bool isListCons (_, i) = i == "[]" --- Check whether an identifier represents the list constructor `:` isConsCons :: QName -> Bool isConsCons (_, i) = i == ":" --- Check whether an identifier represents a tuple constructor isTupleCons :: QName -> Bool isTupleCons (_, i) = i == mkTuple (length i) where mkTuple n = '(' : replicate (n - 2) ',' ++ ")" --- Check if given application tree represents an if then else construct. --- If so, return the condition, the "then expression" and the "else expression". --- Otherwise, return `Nothing`. extractITE :: CExpr -> Maybe (CExpr, CExpr, CExpr) extractITE e = case e of CApply (CApply (CApply (CSymbol ("Prelude","if_then_else")) cond) tExp) fExp -> Just (cond, tExp, fExp) _ -> Nothing --- Check if given application tree represents an infix operator application. --- If so, return the operator, its left and its right argument. Otherwise, --- return `Nothing`. extractInfix :: CExpr -> Maybe (QName, CExpr, CExpr) extractInfix e = case e of CApply (CApply (CSymbol s) e1) e2 | isInfixId s -> Just (s, e1, e2) _ -> Nothing --- Check if given application tree represents a tuple contructor application. --- If so, return the constructor and its arguments in a list. Otherwise, return --- `Nothing`. extractTuple :: CExpr -> Maybe [CExpr] extractTuple = extractTuple' [] where extractTuple' es exp = case exp of CApply f e -> extractTuple' (e:es) f CSymbol s | isTupleCons s -> Just es _ -> Nothing --- Check if given application tree represents a finite list `[x1, ..., xn]`. --- If so, return the list elements in a list. Otherwise, return `Nothing`. extractFiniteListExp :: CExpr -> Maybe [CExpr] extractFiniteListExp = extractFiniteListExp' [] where extractFiniteListExp' es exp = case exp of CApply (CApply (CSymbol f) e) arg | isConsCons f -> extractFiniteListExp' (e:es) arg CSymbol s | isListCons s -> Just $ reverse es _ -> Nothing --- Check if given construct pattern represents a finite list `[x1, ..., xn]`. --- If so, return the list elements in a list. Otherwise, return `Nothing`. extractFiniteListPattern :: CPattern -> Maybe [CPattern] extractFiniteListPattern = extractFiniteListPattern' [] where extractFiniteListPattern' es pat = case pat of CPComb qn [e, t] | isConsCons qn -> extractFiniteListPattern' (e:es) t CPComb qn [] | isListCons qn -> Just $ reverse es _ -> Nothing -- Helping functions (pretty-printing) hsepMap :: (a -> Doc) -> [a] -> Doc hsepMap f = hsep . map f vcatMap :: (a -> Doc) -> [a] -> Doc vcatMap f = vcat . map f vsepMap :: (a -> Doc) -> [a] -> Doc vsepMap f = vsep . map f vsepBlankMap :: (a -> Doc) -> [a] -> Doc vsepBlankMap f = vsepBlank . map f vvsep :: [Doc] -> Doc vvsep = compose (<$!$>) vvsepMap :: (a -> Doc) -> [a] -> Doc vvsepMap f = vvsep . map f fillSepMap :: (a -> Doc) -> [a] -> Doc fillSepMap f = fillSep . map f encloseSepSpaced :: Doc -> Doc -> Doc -> [Doc] -> Doc encloseSepSpaced l r s = encloseSep (l <> space) (space <> r) (s <> space) alignedList :: [Doc] -> Doc alignedList = encloseSep lbracket rbracket comma filledList :: [Doc] -> Doc filledList = fillEncloseSep lbracket rbracket comma alignedSetSpaced :: [Doc] -> Doc alignedSetSpaced = encloseSepSpaced lbrace rbrace comma alignedTupled :: [Doc] -> Doc alignedTupled = encloseSep lparen rparen comma filledTupled :: [Doc] -> Doc filledTupled = fillEncloseSep lparen rparen comma filledTupledSpaced :: [Doc] -> Doc filledTupledSpaced = fillEncloseSepSpaced lparen rparen comma nest' :: Options -> Doc -> Doc nest' opts = nest (indentationWidth opts) indent' :: Options -> Doc -> Doc indent' opts = indent (indentationWidth opts) bquotesIf :: Bool -> Doc -> Doc bquotesIf b d = if b then bquotes d else d parsIfInfix :: QName -> Doc -> Doc parsIfInfix = parensIf . isInfixId larrow :: Doc larrow = text "<-" where_ :: Doc where_ = text "where" nil :: Doc nil = text "[]" -- Helping functions (various) on' :: (b -> b -> c) -> (a -> b) -> (a -> b) -> a -> c on' comb f g x = f x `comb` g x -- Helping functions (CRUD functions for Collection) emptyCol :: Collection a emptyCol = [] appendCol :: Collection a -> Collection a -> Collection a appendCol = (++) anyCol :: (a -> Bool) -> Collection a -> Bool anyCol = any fromList :: [a] -> Collection a fromList = id -- Helping functions (management of visible names) addVarsToOpts :: [CVarIName] -> Options -> Options addVarsToOpts vs o = o { visibleVariables = fromList vs `appendCol` visibleVariables o } addFuncNamesToOpts :: [QName] -> Options -> Options addFuncNamesToOpts ns o = o { visibleFunctions = fromList ns `appendCol` visibleFunctions o } addVarsAndFuncNamesToOpts :: [CVarIName] -> [QName] -> Options -> Options addVarsAndFuncNamesToOpts vs ns = addVarsToOpts vs . addFuncNamesToOpts ns --- Generates a list of options with increasing numbers of visible variables --- and function names. Resulting lists are useful to match the scopes of --- do expressions and list comprehensions, where latter statements see previous --- variables and functions names, but prior elements do not see subsequent --- variables and function names. --- Note that `last $ optsWithIncreasingNamespaces varsOf funcNamesOf xs opts` --- are options which contain all variables and function names of xs. --- @param varsOf - a projection function --- @param funcNamesOf - a projection function --- @xs - a list [x1, x2, ...] of elements to which the projection functions --- will be applied --- @param opts - root options --- @return a list `[opts0, opts1, opts2, ...]`, where --- `opts == opts0`, --- `opts1 == opts0` plus vars and funcNames of `x1`, --- `opts2 == opts1` plus vars and funcNames of `x2`, --- ... optsWithIncreasingNamespaces :: (a -> [CVarIName]) -> (a -> [QName]) -> [a] -> Options -> [Options] optsWithIncreasingNamespaces varsOf funcNamesOf xs opts = scanl (flip . uncurry $ addVarsAndFuncNamesToOpts) opts varsAndFuncNamesOfXs where varsAndFuncNamesOfXs = map varsOf xs `zip` map funcNamesOf xs -- Helping function (gather variables occurring in argument) --- In contrast to `AbstractCurry.Select.varsOfLDecl`, this function does not --- include variables of right hand sides. varsOfLDecl :: CLocalDecl -> [CVarIName] varsOfLDecl (CLocalFunc f ) = varsOfFDecl f varsOfLDecl (CLocalPat p _) = varsOfPat p varsOfLDecl (CLocalVars lvars ) = lvars --- In contrast to `AbstractCurry.Select.varsOfFDecl`, this function does not --- include variables of right hand sides. varsOfFDecl :: CFuncDecl -> [CVarIName] varsOfFDecl (CFunc _ _ _ _ r) = concatMap varsOfRule r varsOfFDecl (CmtFunc _ _ _ _ _ r) = concatMap varsOfRule r where varsOfRule (CRule pats _) = concatMap varsOfPat pats --- In contrast to `AbstractCurry.Select.varsOfStat`, this function does not --- include variables of right hand sides. varsOfStat :: CStatement -> [CVarIName] varsOfStat (CSExpr _ ) = [] varsOfStat (CSPat p _) = varsOfPat p varsOfStat (CSLet ld ) = concatMap varsOfLDecl ld curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/AbstractCurry/Select.curry000066400000000000000000000264331305333611600263350ustar00rootroot00000000000000------------------------------------------------------------------------ --- This library provides some useful operations to select components --- in AbstractCurry programs, i.e., it provides a collection of --- selector functions for AbstractCurry. --- --- @version May 2016 --- @category meta ------------------------------------------------------------------------ module AbstractCurry.Select ( progName, imports, functions, constructors, types, publicFuncNames , publicConsNames, publicTypeNames , typeName, typeVis, typeCons , consName, consVis , isBaseType, isPolyType, isFunctionalType, isIOType, isIOReturnType , argTypes, resultType, tvarsOfType, tconsOfType, modsOfType , funcName, funcArity, funcComment, funcVis, funcType, funcRules , ruleRHS, ldeclsOfRule , varsOfPat, varsOfExp, varsOfRhs, varsOfStat, varsOfLDecl , varsOfFDecl, varsOfRule , funcNamesOfLDecl, funcNamesOfFDecl, funcNamesOfStat , isPrelude ) where import AbstractCurry.Types import List(union) ------------------------------------------------------------------------ -- Selectors for curry programs -- Returns the name of a given Curry program. progName :: CurryProg -> String progName (CurryProg modname _ _ _ _) = modname --- Returns the imports (module names) of a given Curry program. imports :: CurryProg -> [MName] imports (CurryProg _ ms _ _ _) = ms --- Returns the function declarations of a given Curry program. functions :: CurryProg -> [CFuncDecl] functions (CurryProg _ _ _ fs _) = fs --- Returns all constructors of given Curry program. constructors :: CurryProg -> [CConsDecl] constructors = concatMap typeCons . types --- Returns the type declarations of a given Curry program. types :: CurryProg -> [CTypeDecl] types (CurryProg _ _ ts _ _) = ts --- Returns the names of all visible functions in given Curry program. publicFuncNames :: CurryProg -> [QName] publicFuncNames = map funcName . filter ((== Public) . funcVis) . functions --- Returns the names of all visible constructors in given Curry program. publicConsNames :: CurryProg -> [QName] publicConsNames = map consName . filter ((== Public) . consVis) . constructors --- Returns the names of all visible types in given Curry program. publicTypeNames :: CurryProg -> [QName] publicTypeNames = map typeName . filter ((== Public) . typeVis) . types ------------------------------------------------------------------------ -- Selectors for type expressions --- Returns the name of a given type declaration typeName :: CTypeDecl -> QName typeName (CType n _ _ _) = n typeName (CTypeSyn n _ _ _) = n typeName (CNewType n _ _ _) = n --- Returns the visibility of a given type declaration typeVis :: CTypeDecl -> CVisibility typeVis (CType _ vis _ _) = vis typeVis (CTypeSyn _ vis _ _) = vis typeVis (CNewType _ vis _ _) = vis --- Returns the constructors of a given type declaration. typeCons :: CTypeDecl -> [CConsDecl] typeCons (CType _ _ _ cs) = cs typeCons (CTypeSyn _ _ _ _ ) = [] typeCons (CNewType _ _ _ c ) = [c] --- Returns the name of a given constructor declaration. consName :: CConsDecl -> QName consName (CCons n _ _) = n consName (CRecord n _ _) = n --- Returns the visibility of a given constructor declaration. consVis :: CConsDecl -> CVisibility consVis (CCons _ vis _) = vis consVis (CRecord _ vis _) = vis --- Returns true if the type expression is a base type. isBaseType :: CTypeExpr -> Bool isBaseType texp = case texp of CTCons _ args -> null args _ -> False --- Returns true if the type expression contains type variables. isPolyType :: CTypeExpr -> Bool isPolyType (CTVar _) = True isPolyType (CFuncType domain range) = isPolyType domain || isPolyType range isPolyType (CTCons _ typelist) = any isPolyType typelist --- Returns true if the type expression is a functional type. isFunctionalType :: CTypeExpr -> Bool isFunctionalType texp = case texp of CFuncType _ _ -> True _ -> False --- Returns true if the type expression is (IO t). isIOType :: CTypeExpr -> Bool isIOType texp = case texp of CTCons tc _ -> tc == pre "IO" _ -> False --- Returns true if the type expression is (IO t) with t/=() and --- t is not functional isIOReturnType :: CTypeExpr -> Bool isIOReturnType (CTVar _) = False isIOReturnType (CFuncType _ _) = False isIOReturnType (CTCons tc typelist) = tc==pre "IO" && head typelist /= CTCons (pre "()") [] && not (isFunctionalType (head typelist)) --- Returns all argument types from a functional type argTypes :: CTypeExpr -> [CTypeExpr] argTypes (CTVar _) = [] argTypes (CTCons _ _) = [] argTypes (CFuncType t1 t2) = t1 : argTypes t2 --- Return the result type from a (nested) functional type resultType :: CTypeExpr -> CTypeExpr resultType (CTVar n) = CTVar n resultType (CTCons name args) = CTCons name args resultType (CFuncType _ t2) = resultType t2 --- Returns all type variables occurring in a type expression. tvarsOfType :: CTypeExpr -> [CTVarIName] tvarsOfType (CTVar v) = [v] tvarsOfType (CFuncType t1 t2) = tvarsOfType t1 ++ tvarsOfType t2 tvarsOfType (CTCons _ args) = concatMap tvarsOfType args --- Returns all type constructors used in the given type. tconsOfType :: CTypeExpr -> [QName] tconsOfType (CTVar _) = [] tconsOfType (CFuncType t1 t2) = tconsOfType t1 `union` tconsOfType t2 tconsOfType (CTCons tc tys) = foldr union [tc] $ map tconsOfType tys --- Returns all modules used in the given type. modsOfType :: CTypeExpr -> [String] modsOfType = map fst . tconsOfType ------------------------------------------------------------------------ -- Selectors for function definitions --- Returns the name of a given function declaration. funcName :: CFuncDecl -> QName funcName (CFunc n _ _ _ _) = n funcName (CmtFunc _ n _ _ _ _) = n -- Returns the visibility of a given function declaration. funcArity :: CFuncDecl -> Int funcArity (CFunc _ a _ _ _) = a funcArity (CmtFunc _ _ a _ _ _) = a --- Returns the documentation comment of a given function declaration. funcComment :: CFuncDecl -> String funcComment (CFunc _ _ _ _ _) = "" funcComment (CmtFunc cmt _ _ _ _ _) = cmt --- Returns the visibility of a given function declaration. funcVis :: CFuncDecl -> CVisibility funcVis (CFunc _ _ vis _ _) = vis funcVis (CmtFunc _ _ _ vis _ _) = vis --- Returns the type of a given function declaration. funcType :: CFuncDecl -> CTypeExpr funcType (CFunc _ _ _ texp _) = texp funcType (CmtFunc _ _ _ _ texp _) = texp --- Returns the rules of a given function declaration. funcRules :: CFuncDecl -> [CRule] funcRules (CFunc _ _ _ _ rules) = rules funcRules (CmtFunc _ _ _ _ _ rules) = rules ------------------------------------------------------------------------ -- Selectors for rules. --- Returns the right-hand side of a rules. ruleRHS :: CRule -> CRhs ruleRHS (CRule _ rhs) = rhs --- Returns the local declarations of given rule. ldeclsOfRule :: CRule -> [CLocalDecl] ldeclsOfRule (CRule _ (CSimpleRhs _ lDecls)) = lDecls ldeclsOfRule (CRule _ (CGuardedRhs _ lDecls)) = lDecls ------------------------------------------------------------------------ -- Operations to compute the variables occurring in a pattern or expression: --- Returns list of all variables occurring in a pattern. --- Each occurrence corresponds to one element, i.e., the list might --- contain multiple elements. varsOfPat :: CPattern -> [CVarIName] varsOfPat (CPVar v) = [v] varsOfPat (CPLit _) = [] varsOfPat (CPComb _ pats) = concatMap varsOfPat pats varsOfPat (CPAs v pat) = v : varsOfPat pat varsOfPat (CPFuncComb _ pats) = concatMap varsOfPat pats varsOfPat (CPLazy pat) = varsOfPat pat varsOfPat (CPRecord _ recpats) = concatMap (varsOfPat . snd) recpats --- Returns list of all variables occurring in an expression. --- Each occurrence corresponds to one element, i.e., the list might --- contain multiple elements. varsOfExp :: CExpr -> [CVarIName] varsOfExp (CVar v) = [v] varsOfExp (CLit _) = [] varsOfExp (CSymbol _) = [] varsOfExp (CApply e1 e2) = varsOfExp e1 ++ varsOfExp e2 varsOfExp (CLambda pl le) = concatMap varsOfPat pl ++ varsOfExp le varsOfExp (CLetDecl ld le) = concatMap varsOfLDecl ld ++ varsOfExp le varsOfExp (CDoExpr sl) = concatMap varsOfStat sl varsOfExp (CListComp le sl) = varsOfExp le ++ concatMap varsOfStat sl varsOfExp (CCase _ ce bl) = varsOfExp ce ++ concatMap (\ (p,rhs) -> varsOfPat p ++ varsOfRhs rhs) bl varsOfExp (CTyped te _) = varsOfExp te varsOfExp (CRecConstr _ upds) = concatMap (varsOfExp . snd) upds varsOfExp (CRecUpdate e upds) = varsOfExp e ++ concatMap (varsOfExp . snd) upds --- Returns list of all variables occurring in a right-hand side. --- Each occurrence corresponds to one element, i.e., the list might --- contain multiple elements. varsOfRhs :: CRhs -> [CVarIName] varsOfRhs (CSimpleRhs rhs ldecls) = varsOfExp rhs ++ concatMap varsOfLDecl ldecls varsOfRhs (CGuardedRhs gs ldecls) = concatMap (\ (g,e) -> varsOfExp g ++ varsOfExp e) gs ++ concatMap varsOfLDecl ldecls --- Returns list of all variables occurring in a statement. --- Each occurrence corresponds to one element, i.e., the list might --- contain multiple elements. varsOfStat :: CStatement -> [CVarIName] varsOfStat (CSExpr e) = varsOfExp e varsOfStat (CSPat p e) = varsOfPat p ++ varsOfExp e varsOfStat (CSLet ld) = concatMap varsOfLDecl ld --- Returns list of all variables occurring in a local declaration. --- Each occurrence corresponds to one element, i.e., the list might --- contain multiple elements. varsOfLDecl :: CLocalDecl -> [CVarIName] varsOfLDecl (CLocalFunc f) = varsOfFDecl f varsOfLDecl (CLocalPat p rhs) = varsOfPat p ++ varsOfRhs rhs varsOfLDecl (CLocalVars lvars) = lvars --- Returns list of all variables occurring in a function declaration. --- Each occurrence corresponds to one element, i.e., the list might --- contain multiple elements. varsOfFDecl :: CFuncDecl -> [CVarIName] varsOfFDecl (CFunc _ _ _ _ r) = concatMap varsOfRule r varsOfFDecl (CmtFunc _ _ _ _ _ r) = concatMap varsOfRule r --- Returns list of all variables occurring in a rule. --- Each occurrence corresponds to one element, i.e., the list might --- contain multiple elements. varsOfRule :: CRule -> [CVarIName] varsOfRule (CRule pats rhs) = concatMap varsOfPat pats ++ varsOfRhs rhs ------------------------------------------------------------------------ -- Operations to compute the function names declared in functions, local -- declarations and statements: --- @return The declared function name of given local declaration in a list. funcNamesOfLDecl :: CLocalDecl -> [QName] funcNamesOfLDecl lDecl = case lDecl of CLocalFunc f -> funcNamesOfFDecl f _ -> [] --- @return The declared function name of given function declaration in a list. funcNamesOfFDecl :: CFuncDecl -> [QName] funcNamesOfFDecl (CFunc qn _ _ _ _) = [qn] funcNamesOfFDecl (CmtFunc _ qn _ _ _ _) = [qn] --- @return The declared function names of given statement in a list. funcNamesOfStat :: CStatement -> [QName] funcNamesOfStat stms = case stms of CSLet ld -> concatMap funcNamesOfLDecl ld _ -> [] ------------------------------------------------------------------------ --- Tests whether a module name is the prelude. isPrelude :: String -> Bool isPrelude m = m == "Prelude" ------------------------------------------------------------------------ curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/AbstractCurry/Transform.curry000066400000000000000000000464731305333611600270770ustar00rootroot00000000000000---------------------------------------------------------------------------- --- This library provides transformation and update operations --- on AbstractCurry programs. --- Since the transformations are defined recursively on structured types, --- they are useful to construct specific transformations on AbstractCurry --- programs. --- In particular, this library contains the transformation --- `renameCurryModule` to rename an AbstractCurry module. --- --- @author Michael Hanus --- @version April 2016 --- @category meta ---------------------------------------------------------------------------- module AbstractCurry.Transform where import AbstractCurry.Types import AbstractCurry.Select import List (nub, union) --- This type synonym is useful to denote the type of an update, --- where the first argument is the type of values which are updated --- by the local update (which acts on types described by the second argument). type Update a b = (b -> b) -> a -> a ---------------------------------------------------------------------------- -- CurryProg --- Transforms an AbstractCurry program. trCProg :: (String -> [String] -> [CTypeDecl] -> [CFuncDecl] -> [COpDecl] -> a) -> CurryProg -> a trCProg prog (CurryProg name imps types funcs ops) = prog name imps types funcs ops --- Updates an AbstractCurry program. updCProg :: (String -> String) -> ([String] -> [String]) -> ([CTypeDecl] -> [CTypeDecl]) -> ([CFuncDecl] -> [CFuncDecl]) -> ([COpDecl] -> [COpDecl]) -> CurryProg -> CurryProg updCProg fn fi ft ff fo = trCProg prog where prog name imps types funcs ops = CurryProg (fn name) (fi imps) (ft types) (ff funcs) (fo ops) --- Updates the name of a Curry program. updCProgName :: Update CurryProg String updCProgName f = updCProg f id id id id ---------------------------------------------------------------------------- -- CTypeDecl --- Transforms a type declaration. trCTypeDecl :: (QName -> CVisibility -> [CTVarIName] -> [CConsDecl] -> a) -> (QName -> CVisibility -> [CTVarIName] -> CTypeExpr -> a) -> (QName -> CVisibility -> [CTVarIName] -> CConsDecl -> a) -> CTypeDecl -> a trCTypeDecl typ _ _ (CType name vis params cs) = typ name vis params cs trCTypeDecl _ tsyn _ (CTypeSyn name vis params syn) = tsyn name vis params syn trCTypeDecl _ _ tntyp (CNewType name vis params nt) = tntyp name vis params nt --- update type declaration updCTypeDecl :: (QName -> QName) -> (CVisibility -> CVisibility) -> ([CTVarIName] -> [CTVarIName]) -> ([CConsDecl] -> [CConsDecl]) -> (CTypeExpr -> CTypeExpr) -> (CConsDecl -> CConsDecl) -> CTypeDecl -> CTypeDecl updCTypeDecl fn fv fp fc fs ft = trCTypeDecl typ tsyn tntyp where typ name vis params cs = CType (fn name) (fv vis) (fp params) (fc cs) tsyn name vis params syn = CTypeSyn (fn name) (fv vis) (fp params) (fs syn) tntyp name vis params ntyp = CNewType (fn name) (fv vis) (fp params) (ft ntyp) --- Updates the name of a type declaration. updCTypeDeclName :: Update CTypeDecl QName updCTypeDeclName f = updCTypeDecl f id id id id id ---------------------------------------------------------------------------- -- CConsDecl --- Transforms a constructor declaration. trCConsDecl :: (QName -> CVisibility -> [CTypeExpr] -> a) -> (QName -> CVisibility -> [CFieldDecl] -> a) -> CConsDecl -> a trCConsDecl cons _ (CCons name vis args) = cons name vis args trCConsDecl _ rec (CRecord name vis args) = rec name vis args --- Updates a constructor declaration. updCConsDecl :: (QName -> QName) -> (CVisibility -> CVisibility) -> ([CTypeExpr] -> [CTypeExpr]) -> ([CFieldDecl] -> [CFieldDecl]) -> CConsDecl -> CConsDecl updCConsDecl fn fv fts ffs = trCConsDecl cons rec where cons name vis args = CCons (fn name) (fv vis) (fts args) rec name vis args = CRecord (fn name) (fv vis) (ffs args) --- Updates the name of a constructor declaration. updCConsDeclName :: Update CConsDecl QName updCConsDeclName f = updCConsDecl f id id id ---------------------------------------------------------------------------- -- CFieldDecl --- Transforms a constructor declaration. trCFieldDecl :: (QName -> CVisibility -> CTypeExpr -> a) -> CFieldDecl -> a trCFieldDecl field (CField name vis texp) = field name vis texp --- update constructor declaration updCFieldDecl :: (QName -> QName) -> (CVisibility -> CVisibility) -> (CTypeExpr -> CTypeExpr) -> CFieldDecl -> CFieldDecl updCFieldDecl fn fv ft = trCFieldDecl field where field name vis texp = CField (fn name) (fv vis) (ft texp) --- Updates the name of a constructor declaration. updCFieldDeclName :: Update CFieldDecl QName updCFieldDeclName f = updCFieldDecl f id id ---------------------------------------------------------------------------- -- CTypeExpr --- Transforms a type expression. trCTypeExpr :: (CTVarIName -> a) -> (QName -> [a] -> a) -> (a -> a -> a) -> CTypeExpr -> a trCTypeExpr tvar tcons functype texp = trTE texp where trTE (CTVar n) = tvar n trTE (CTCons name args) = tcons name (map trTE args) trTE (CFuncType from to) = functype (trTE from) (trTE to) --- Updates all type constructor applications in a type expression. updTConsApp :: (QName -> [CTypeExpr] -> CTypeExpr) -> CTypeExpr -> CTypeExpr updTConsApp tcons = trCTypeExpr CTVar tcons CFuncType ---------------------------------------------------------------------------- -- COpDecl --- Transforms an operator declaration. trCOpDecl :: (QName -> CFixity -> Int -> a) -> COpDecl -> a trCOpDecl op (COp name fix prec) = op name fix prec --- Updates an operator declaration. updCOpDecl :: (QName -> QName) -> (CFixity -> CFixity) -> (Int -> Int) -> COpDecl -> COpDecl updCOpDecl fn ff fp = trCOpDecl op where op name fix prec = COp (fn name) (ff fix) (fp prec) --- Updates the name of an operator declaration. updCOpName :: Update COpDecl QName updCOpName f = updCOpDecl f id id ---------------------------------------------------------------------------- -- CFuncDecl --- Transforms a function declaration trCFuncDecl :: (String -> QName -> Int -> CVisibility -> CTypeExpr -> [CRule] -> a) -> CFuncDecl -> a trCFuncDecl func (CFunc name arity vis t rs) = func "" name arity vis t rs trCFuncDecl func (CmtFunc cm name arity vis t rs) = func cm name arity vis t rs --- Updates a function declaration. updCFuncDecl :: (String -> String) -> (QName -> QName) -> (Int -> Int) -> (CVisibility -> CVisibility) -> (CTypeExpr -> CTypeExpr) -> ([CRule] -> [CRule]) -> CFuncDecl -> CFuncDecl updCFuncDecl fc fn fa fv ft fr = trCFuncDecl func where func cmt name arity vis t rules = if null cmt then CFunc (fn name) (fa arity) (fv vis) (ft t) (fr rules) else CmtFunc (fc cmt) (fn name) (fa arity) (fv vis) (ft t) (fr rules) ---------------------------------------------------------------------------- -- CRule --- Transform a rule. trCRule :: ([CPattern] -> CRhs -> a) -> CRule -> a trCRule rule (CRule pats rhs) = rule pats rhs --- Update a rule. updCRule :: ([CPattern] -> [CPattern]) -> (CRhs -> CRhs) -> CRule -> CRule updCRule fp fr = trCRule rule where rule pats rhs = CRule (fp pats) (fr rhs) ---------------------------------------------------------------------------- -- CRhs --- Transforms a right-hand side (of a rule or case expression). trCRhs :: (CExpr -> [CLocalDecl] -> a) -> ([(CExpr, CExpr)] -> [CLocalDecl] -> a) -> CRhs -> a trCRhs srhs _ (CSimpleRhs exp locals) = srhs exp locals trCRhs _ grhs (CGuardedRhs gexps locals) = grhs gexps locals --- Updates right-hand side. updCRhs :: (CExpr -> CExpr) -> ([(CExpr, CExpr)] -> [(CExpr, CExpr)]) -> ([CLocalDecl] -> [CLocalDecl]) -> CRhs -> CRhs updCRhs fe fg fl = trCRhs srhs grhs where srhs exp locals = CSimpleRhs (fe exp) (fl locals) grhs gexps locals = CGuardedRhs (fg gexps) (fl locals) ---------------------------------------------------------------------------- -- CLocalDecl --- Transforms a local declaration. trCLocalDecl :: (CFuncDecl -> a) -> (CPattern -> CRhs -> a) -> ([CVarIName] -> a) -> CLocalDecl -> a trCLocalDecl lfun _ _ (CLocalFunc fdecl) = lfun fdecl trCLocalDecl _ lpat _ (CLocalPat pat rhs) = lpat pat rhs trCLocalDecl _ _ vars (CLocalVars vs) = vars vs --- Updates a local declaration. updCLocalDecl :: (CFuncDecl -> CFuncDecl) -> (CPattern -> CPattern) -> (CRhs -> CRhs) -> ([CVarIName] -> [CVarIName]) -> CLocalDecl -> CLocalDecl updCLocalDecl ff fp fr fv = trCLocalDecl lfun lpat lvars where lfun fdecl = CLocalFunc (ff fdecl) lpat pat rhs = CLocalPat (fp pat) (fr rhs) lvars vars = CLocalVars (fv vars) ---------------------------------------------------------------------------- -- CPattern --- Transforms a pattern. trCPattern :: (CVarIName -> a) -> (CLiteral -> a) -> (QName -> [a] -> a) -> (CVarIName -> a -> a) -> (QName -> [a] -> a) -> (QName -> [CField a] -> a) -> CPattern -> a trCPattern fv fl fc fa ff fr pattern = trP pattern where trP (CPVar pvar) = fv pvar trP (CPLit lit) = fl lit trP (CPComb c pats) = fc c (map trP pats) trP (CPAs v pat) = fa v (trP pat) trP (CPFuncComb fn pats) = ff fn (map trP pats) trP (CPLazy pat) = trP pat trP (CPRecord r fs) = fr r (map (\(n,p) -> (n,trP p)) fs) --- Updates a pattern. updCPattern :: (CVarIName -> CVarIName) -> (CLiteral -> CLiteral) -> (QName -> QName) -> CPattern -> CPattern updCPattern fv fl fn = trCPattern pvar plit pcomb pas pfcomb prec where pvar var = CPVar (fv var) plit lit = CPLit (fl lit) pcomb c pats = CPComb (fn c) (map (updCPattern fv fl fn) pats) pas v pat = CPAs (fv v) (updCPattern fv fl fn pat) pfcomb f pats = CPFuncComb (fn f) (map (updCPattern fv fl fn) pats) prec r fields = CPRecord (fn r) (map (\ (n,p) -> (fn n, updCPattern fv fl fn p)) fields) ---------------------------------------------------------------------------- -- CExpr --- Transforms an expression. trExpr :: (CVarIName -> a) -> (CLiteral -> a) -> (QName -> a) -> (a -> a -> a) -> ([CPattern] -> a -> a) -> ([CLocalDecl] -> a -> a) -> ([CStatement] -> a) -> (a -> [CStatement] -> a) -> (CCaseType -> a -> [(CPattern, CRhs)] -> a) -> (a -> CTypeExpr -> a) -> (QName -> [CField a] -> a) -> (a -> [CField a] -> a) -> CExpr -> a trExpr var lit sym app lam clet cdo lcomp cas typ rcon rupd exp = trE exp where trE (CVar n) = var n trE (CLit l) = lit l trE (CSymbol n) = sym n trE (CApply e1 e2) = app (trE e1) (trE e2) trE (CLambda pats e) = lam pats (trE e) trE (CLetDecl ls e) = clet ls (trE e) trE (CDoExpr stm) = cdo stm trE (CListComp e stm) = lcomp (trE e) stm trE (CCase ct e branches) = cas ct (trE e) branches trE (CTyped e te) = typ (trE e) te trE (CRecConstr rn fds) = rcon rn (map (\ (lb,e) -> (lb, trE e)) fds) trE (CRecUpdate e fds) = rupd (trE e) (map (\ (lb,v) -> (lb, trE v)) fds) ---------------------------------------------------------------------------- -- CStatement --- Transforms a statement (occuring in do expressions or list comprehensions). trCStatement :: (CExpr -> a) -> (CPattern -> CExpr -> a) -> ([CLocalDecl] -> a) -> CStatement -> a trCStatement sexp _ _ (CSExpr exp) = sexp exp trCStatement _ spat _ (CSPat pat exp) = spat pat exp trCStatement _ _ slet (CSLet locals) = slet locals --- Updates a statement (occuring in do expressions or list comprehensions). updCStatement :: (CExpr -> CExpr) -> (CPattern -> CPattern) -> (CLocalDecl -> CLocalDecl) -> CStatement -> CStatement updCStatement fe fp fd = trCStatement sexp spat slet where sexp exp = CSExpr (fe exp) spat pat exp = CSPat (fp pat) (fe exp) slet locals = CSLet (map fd locals) ---------------------------------------------------------------------------- --- Renames a Curry module, i.e., updates the module name and all qualified --- names in a program. renameCurryModule :: String -> CurryProg -> CurryProg renameCurryModule newname prog = updCProgName (const newname) (updQNamesInCProg rnm prog) where rnm mn@(mod,n) | mod == progName prog = (newname,n) | otherwise = mn --- Updates all qualified names in a Curry program. updQNamesInCProg :: Update CurryProg QName updQNamesInCProg f = updCProg id id (map (updQNamesInCTypeDecl f)) (map (updQNamesInCFuncDecl f)) (map (updCOpName f)) --- Updates all qualified names in a type declaration. updQNamesInCTypeDecl :: Update CTypeDecl QName updQNamesInCTypeDecl f = updCTypeDecl f id id (map (updQNamesInCConsDecl f)) (updQNamesInCTypeExpr f) (updQNamesInCConsDecl f) --- Updates all qualified names in a constructor declaration. updQNamesInCConsDecl :: Update CConsDecl QName updQNamesInCConsDecl f = updCConsDecl f id (map (updQNamesInCTypeExpr f)) (map (updQNamesInCFieldDecl f)) --- Updates all qualified names in a record field declaration. updQNamesInCFieldDecl :: Update CFieldDecl QName updQNamesInCFieldDecl f = updCFieldDecl f id (updQNamesInCTypeExpr f) --- Updates all qualified names in a type expression. updQNamesInCTypeExpr :: (QName -> QName) -> CTypeExpr -> CTypeExpr updQNamesInCTypeExpr f = updTConsApp (\name args -> CTCons (f name) args) --- Updates all qualified names in a function declaration. updQNamesInCFuncDecl :: Update CFuncDecl QName updQNamesInCFuncDecl f = updCFuncDecl id f id id (updQNamesInCTypeExpr f) (map (updQNamesInCRule f)) --- Updates all qualified names in a function declaration. updQNamesInCRule :: Update CRule QName updQNamesInCRule f = updCRule (map (updQNamesInCPattern f)) (updQNamesInCRhs f) --- Updates all qualified names in a function declaration. updQNamesInCRhs :: Update CRhs QName updQNamesInCRhs f = updCRhs (updQNamesInCExpr f) (map (\ (g,e) -> (updQNamesInCExpr f g, updQNamesInCExpr f e))) (map (updQNamesInCLocalDecl f)) --- Updates all qualified names in a function declaration. updQNamesInCLocalDecl :: Update CLocalDecl QName updQNamesInCLocalDecl f = updCLocalDecl (updQNamesInCFuncDecl f) (updQNamesInCPattern f) (updQNamesInCRhs f) id --- Updates all qualified names in a function declaration. updQNamesInCPattern :: Update CPattern QName updQNamesInCPattern f = updCPattern id id f --- Updates all qualified names in a statement. updQNamesInCStatement :: Update CStatement QName updQNamesInCStatement f = updCStatement (updQNamesInCExpr f) (updQNamesInCPattern f) (updQNamesInCLocalDecl f) updQNamesInCExpr :: Update CExpr QName updQNamesInCExpr f = trExpr CVar CLit (CSymbol . f) CApply lam ldecl doexp lcomp ccase ctyped reccon recupd where lam pats exp = CLambda (map (updQNamesInCPattern f) pats) exp ldecl locals exp = CLetDecl (map (updQNamesInCLocalDecl f) locals) exp doexp stms = CDoExpr (map (updQNamesInCStatement f) stms) lcomp exp stms = CListComp exp (map (updQNamesInCStatement f) stms) ccase ct exp bs = CCase ct exp (map (\ (pat,rhs) -> (updQNamesInCPattern f pat, updQNamesInCRhs f rhs)) bs) ctyped exp texp = CTyped exp (updQNamesInCTypeExpr f texp) reccon rec fields = CRecConstr (f rec) (map (\ (l,e) -> (f l,e)) fields) recupd exp fields = CRecUpdate exp (map (\ (l,e) -> (f l,e)) fields) ------------------------------------------------------------------------- --- Extracts all type names occurring in a program. typesOfCurryProg :: CurryProg -> [QName] typesOfCurryProg = trCProg (\_ _ types funcs _ -> foldr union [] (map (nub . typesOfCTypeDecl) types) ++ foldr union [] (map (nub . typesOfCFuncDecl) funcs)) --- Extracts all type names occurring in a type declaration. typesOfCTypeDecl :: CTypeDecl -> [QName] typesOfCTypeDecl = trCTypeDecl (\qn _ _ cdecls -> qn : concatMap typesOfConsDecl cdecls) (\qn _ _ texp -> qn : typesOfTypeExpr texp) (\qn _ _ cdecl -> qn : typesOfConsDecl cdecl) typesOfConsDecl :: CConsDecl -> [QName] typesOfConsDecl = trCConsDecl (\_ _ texps -> concatMap typesOfTypeExpr texps) (\_ _ fddecls -> concatMap typesOfFieldDecl fddecls) typesOfFieldDecl :: CFieldDecl -> [QName] typesOfFieldDecl = trCFieldDecl (\_ _ texp -> typesOfTypeExpr texp) typesOfTypeExpr :: CTypeExpr -> [QName] typesOfTypeExpr = trCTypeExpr (\_ -> []) (\qn targs -> qn : concat targs) (++) typesOfCFuncDecl :: CFuncDecl -> [QName] typesOfCFuncDecl = trCFuncDecl (\_ _ _ _ texp _ -> typesOfTypeExpr texp) -- type annotations in expressions are currently ignored ---------------------------------------------------------------------------- --- Extracts all function (and constructor) names occurring in a program. funcsOfCurryProg :: CurryProg -> [QName] funcsOfCurryProg = trCProg (\_ _ types funcs _ -> foldr union [] (map (nub . funcsOfCTypeDecl) types) ++ foldr union [] (map (nub . funcsOfCFuncDecl) funcs)) funcsOfCTypeDecl :: CTypeDecl -> [QName] funcsOfCTypeDecl = trCTypeDecl (\_ _ _ cdecls -> concatMap funcsOfConsDecl cdecls) (\_ _ _ _ -> []) (\_ _ _ cdecl -> funcsOfConsDecl cdecl) funcsOfConsDecl :: CConsDecl -> [QName] funcsOfConsDecl = trCConsDecl (\qn _ _ -> [qn]) (\qn _ fddecls -> qn : concatMap funcsOfFieldDecl fddecls) funcsOfFieldDecl :: CFieldDecl -> [QName] funcsOfFieldDecl = trCFieldDecl (\qn _ _ -> [qn]) --- Extracts all function (and constructor) names occurring in a function --- declaration. funcsOfCFuncDecl :: CFuncDecl -> [QName] funcsOfCFuncDecl = trCFuncDecl (\_ _ _ _ _ rules -> concatMap funcsOfCRule rules) funcsOfCRule :: CRule -> [QName] funcsOfCRule = trCRule (\_ rhs -> funcsOfCRhs rhs) funcsOfCRhs :: CRhs -> [QName] funcsOfCRhs = trCRhs (\e ldecls -> funcsOfExpr e ++ concatMap funcsOfLDecl ldecls) (\gs ldecls -> concatMap (\ (g,e) -> funcsOfExpr g ++ funcsOfExpr e) gs ++ concatMap funcsOfLDecl ldecls) funcsOfLDecl :: CLocalDecl -> [QName] funcsOfLDecl = trCLocalDecl funcsOfCFuncDecl (const funcsOfCRhs) (const []) funcsOfExpr :: CExpr -> [QName] funcsOfExpr = trExpr (const []) (const []) (\n -> [n]) (++) (const id) (\ldecls e -> concatMap funcsOfLDecl ldecls ++ e) (concatMap funcsOfStat) (\e stats -> e ++ concatMap funcsOfStat stats) (\_ e brs -> e ++ concatMap (funcsOfCRhs . snd) brs) (\e _ -> e) (\_ fields -> concatMap snd fields) (\e fields -> e ++ concatMap snd fields) funcsOfStat :: CStatement -> [QName] funcsOfStat = trCStatement funcsOfExpr (const funcsOfExpr) (concatMap funcsOfLDecl) ------------------------------------------------------------------------- curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/AbstractCurry/Types.curry000066400000000000000000000217601305333611600262200ustar00rootroot00000000000000-- --------------------------------------------------------------------------- --- This library contains a definition for representing Curry programs --- in Curry and an I/O action to read Curry programs and --- transform them into this abstract representation. --- --- Note this defines a slightly new format for AbstractCurry --- in comparison to the first proposal of 2003. --- --- Assumption: an abstract Curry program is stored in file with --- extension .acy --- --- @author Michael Hanus, Bjoern Peemoeller --- @version September 2015 --- @category meta -- --------------------------------------------------------------------------- module AbstractCurry.Types where -- --------------------------------------------------------------------------- -- Definition of data types for representing abstract Curry programs: -- --------------------------------------------------------------------------- --- Current version of AbstractCurry version :: String version = "AbstractCurry 1.0" --- A module name. type MName = String --- The data type for representing qualified names. --- In AbstractCurry all names are qualified to avoid name clashes. --- The first component is the module name and the second component the --- unqualified name as it occurs in the source program. --- An exception are locally defined names where the module name is --- the empty string (to avoid name clashes with a globally defined name). type QName = (MName, String) --- Data type to specify the visibility of various entities. data CVisibility = Public -- exported entity | Private -- private entity --- Data type for representing a Curry module in the intermediate form. --- A value of this data type has the form --- --- (CurryProg modname imports typedecls functions opdecls) --- --- where modname: name of this module, --- imports: list of modules names that are imported, --- typedecls: Type declarations --- functions: Function declarations --- opdecls: Operator precedence declarations data CurryProg = CurryProg MName [MName] [CTypeDecl] [CFuncDecl] [COpDecl] --- Data type for representing definitions of algebraic data types --- and type synonyms. --- --- A data type definition of the form --- --- data t x1...xn = ...| c t1....tkc |... --- --- is represented by the Curry term --- --- (CType t v [i1,...,in] [...(CCons c kc v [t1,...,tkc])...]) --- --- where each `ij` is the index of the type variable `xj`. --- --- Note: the type variable indices are unique inside each type declaration --- and are usually numbered from 0 --- --- Thus, a data type declaration consists of the name of the data type, --- a list of type parameters and a list of constructor declarations. data CTypeDecl = CType QName CVisibility [CTVarIName] [CConsDecl] | CTypeSyn QName CVisibility [CTVarIName] CTypeExpr | CNewType QName CVisibility [CTVarIName] CConsDecl --- The type for representing type variables. --- They are represented by (i,n) where i is a type variable index --- which is unique inside a function and n is a name (if possible, --- the name written in the source program). type CTVarIName = (Int, String) --- A constructor declaration consists of the name of the --- constructor and a list of the argument types of the constructor. --- The arity equals the number of types. data CConsDecl = CCons QName CVisibility [CTypeExpr] | CRecord QName CVisibility [CFieldDecl] --- A record field declaration consists of the name of the --- the label, the visibility and its corresponding type. data CFieldDecl = CField QName CVisibility CTypeExpr --- Type expression. --- A type expression is either a type variable, a function type, --- or a type constructor application. --- --- Note: the names of the predefined type constructors are --- "Int", "Float", "Bool", "Char", "IO", --- "()" (unit type), "(,...,)" (tuple types), "[]" (list type) data CTypeExpr = CTVar CTVarIName -- type variable | CFuncType CTypeExpr CTypeExpr -- function type t1->t2 | CTCons QName [CTypeExpr] -- type constructor application -- (CTCons (module,name) arguments) --- Labeled record fields type CField a = (QName, a) --- Data type for operator declarations. --- An operator declaration "fix p n" in Curry corresponds to the --- AbstractCurry term (COp n fix p). data COpDecl = COp QName CFixity Int --- Data type for operator associativity data CFixity = CInfixOp -- non-associative infix operator | CInfixlOp -- left-associative infix operator | CInfixrOp -- right-associative infix operator --- Function arity type Arity = Int --- Data type for representing function declarations. --- --- A function declaration in AbstractCurry is a term of the form --- --- (CFunc name arity visibility type (CRules eval [CRule rule1,...,rulek])) --- --- and represents the function name defined by the rules --- rule1,...,rulek. --- --- Note: the variable indices are unique inside each rule --- --- Thus, a function declaration consists of the name, arity, type, and --- a list of rules. --- --- A function declaration with the constructor CmtFunc --- is similarly to CFunc but has a comment --- as an additional first argument. This comment could be used --- by pretty printers that generate a readable Curry program --- containing documentation comments. data CFuncDecl = CFunc QName Arity CVisibility CTypeExpr [CRule] | CmtFunc String QName Arity CVisibility CTypeExpr [CRule] --- The general form of a function rule. It consists of a list of patterns --- (left-hand side) and the right-hand side for these patterns. data CRule = CRule [CPattern] CRhs --- Right-hand-side of a 'CRule' or a `case` expression. --- It is either a simple unconditional right-hand side or --- a list of guards with their corresponding right-hand sides, and --- a list of local declarations. data CRhs = CSimpleRhs CExpr [CLocalDecl] -- expr where decls | CGuardedRhs [(CExpr, CExpr)] [CLocalDecl] -- | cond = expr where decls --- Data type for representing local (let/where) declarations data CLocalDecl = CLocalFunc CFuncDecl -- local function declaration | CLocalPat CPattern CRhs -- local pattern declaration | CLocalVars [CVarIName] -- local free variable declaration --- Data types for representing object variables. --- Object variables occurring in expressions are represented by (Var i) --- where i is a variable index. type CVarIName = (Int,String) --- Data type for representing pattern expressions. data CPattern = CPVar CVarIName -- pattern variable (unique index / name) | CPLit CLiteral -- literal (Integer/Float/Char constant) | CPComb QName [CPattern] -- application (m.c e1 ... en) of n-ary -- constructor m.c (CPComb (m,c) [e1,...,en]) | CPAs CVarIName CPattern -- as-pattern (extended Curry) | CPFuncComb QName [CPattern] -- function pattern (extended Curry) | CPLazy CPattern -- lazy pattern (extended Curry) | CPRecord QName [CField CPattern] -- record pattern (extended Curry) --- Data type for representing Curry expressions. data CExpr = CVar CVarIName -- variable (unique index / name) | CLit CLiteral -- literal (Integer/Float/Char constant) | CSymbol QName -- a defined symbol with module and name | CApply CExpr CExpr -- application (e1 e2) | CLambda [CPattern] CExpr -- lambda abstraction | CLetDecl [CLocalDecl] CExpr -- local let declarations | CDoExpr [CStatement] -- do expression | CListComp CExpr [CStatement] -- list comprehension | CCase CCaseType CExpr [(CPattern, CRhs)] -- case expression | CTyped CExpr CTypeExpr -- typed expression | CRecConstr QName [CField CExpr] -- record construction (extended Curry) | CRecUpdate CExpr [CField CExpr] -- record update (extended Curry) --- Data type for representing literals occurring in an expression. --- It is either an integer, a float, or a character constant. data CLiteral = CIntc Int | CFloatc Float | CCharc Char | CStringc String --- Data type for representing statements in do expressions and --- list comprehensions. data CStatement = CSExpr CExpr -- an expression (I/O action or boolean) | CSPat CPattern CExpr -- a pattern definition | CSLet [CLocalDecl] -- a local let declaration --- Type of case expressions data CCaseType = CRigid -- rigid case expression | CFlex -- flexible case expression --------------------------------------------------------------------------- --- The name of the standard prelude. preludeName :: String preludeName = "Prelude" --- Converts a string into a qualified name of the Prelude. pre :: String -> QName pre f = (preludeName, f) --------------------------------------------------------------------------- curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/AllSolutions.curry000066400000000000000000000061751305333611600247570ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This module contains a collection of functions for --- obtaining lists of solutions to constraints. --- These operations are useful to encapsulate --- non-deterministic operations between I/O actions in --- order to connect the worlds of logic and functional programming --- and to avoid non-determinism failures on the I/O level. --- --- In contrast the "old" concept of encapsulated search --- (which could be applied to any subexpression in a computation), --- the operations to encapsulate search in this module --- are I/O actions in order to avoid some anomalities --- in the old concept. --- --- @category general ------------------------------------------------------------------------------ module AllSolutions(getAllValues,getOneValue,getAllSolutions,getOneSolution, getAllFailures) where import SearchTree --- Gets all values of an expression (currently, via an incomplete --- depth-first strategy). Conceptually, all values are computed --- on a copy of the expression, i.e., the evaluation of the expression --- does not share any results. Moreover, the evaluation suspends --- as long as the expression contains unbound variables. getAllValues :: a -> IO [a] getAllValues e = getSearchTree e >>= return . allValuesDFS --- Gets one value of an expression (currently, via an incomplete --- left-to-right strategy). Returns Nothing if the search space --- is finitely failed. getOneValue :: a -> IO (Maybe a) getOneValue x = do st <- getSearchTree x let vals = allValuesDFS st return (if null vals then Nothing else Just (head vals)) --- Gets all solutions to a constraint (currently, via an incomplete --- depth-first left-to-right strategy). Conceptually, all solutions --- are computed on a copy of the constraint, i.e., the evaluation --- of the constraint does not share any results. Moreover, this --- evaluation suspends if the constraints contain unbound variables. --- Similar to Prolog's findall. getAllSolutions :: (a->Bool) -> IO [a] getAllSolutions c = getAllValues (let x free in (x,c x)) >>= return . map fst --- Gets one solution to a constraint (currently, via an incomplete --- left-to-right strategy). Returns Nothing if the search space --- is finitely failed. getOneSolution :: (a->Bool) -> IO (Maybe a) getOneSolution c = do sols <- getAllSolutions c return (if null sols then Nothing else Just (head sols)) --- Returns a list of values that do not satisfy a given constraint. --- @param x - an expression (a generator evaluable to various values) --- @param c - a constraint that should not be satisfied --- @return A list of all values of e such that (c e) is not provable getAllFailures :: a -> (a->Bool) -> IO [a] getAllFailures generator test = do xs <- getAllValues generator failures <- mapIO (naf test) xs return $ concat failures -- (naf c x) returns [x] if (c x) fails, and [] otherwise. naf :: (a -> Bool) -> a -> IO [a] naf c x = getOneSolution (lambda c x) >>= returner x lambda :: (a -> Bool) -> a -> () -> Bool lambda c x _ = c x returner :: a -> Maybe b -> IO [a] returner x mbl = return (maybe [x] (const []) mbl) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/AllSolutions.curry.pakcs000066400000000000000000000076651305333611600260640ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This module contains a collection of functions for --- obtaining lists of solutions to constraints. --- These operations are useful to encapsulate --- non-deterministic operations between I/O actions in --- order to connects the worlds of logic and functional programming --- and to avoid non-determinism failures on the I/O level. --- --- In contrast the "old" concept of encapsulated search --- (which could be applied to any subexpression in a computation), --- the operations to encapsulate search in this module --- are I/O actions in order to avoid some anomalities --- in the old concept. --- --- @category general ------------------------------------------------------------------------------ module AllSolutions(getAllSolutions,getAllValues, getOneSolution,getOneValue, getAllFailures, getSearchTree,SearchTree(..)) where import Findall --- Gets all solutions to a constraint (currently, via an incomplete --- depth-first left-to-right strategy). Conceptually, all solutions --- are computed on a copy of the constraint, i.e., the evaluation --- of the constraint does not share any results. Moreover, this --- evaluation suspends if the constraints contain unbound variables. --- Similar to Prolog's findall. getAllSolutions :: (a->Bool) -> IO [a] getAllSolutions c = return (findall c) {- -- In principle, getAllSolutions can be defined by getSearchTree as follows: getAllSolutions c = do (Solutions sols) <- getSearchTree [] c return sols -- However, our above definition is slightly more efficient. -} --- Gets all values of an expression. Since this is based on --- getAllSolutions, it inherits the same restrictions. getAllValues :: a -> IO [a] getAllValues e = return (findall (=:=e)) --- Gets one solution to a constraint (currently, via an incomplete --- left-to-right strategy). Returns Nothing if the search space --- is finitely failed. getOneSolution :: (a->Bool) -> IO (Maybe a) getOneSolution c = do sols <- getAllSolutions c return (if null sols then Nothing else Just (head sols)) --- Gets one value of an expression (currently, via an incomplete --- left-to-right strategy). Returns Nothing if the search space --- is finitely failed. getOneValue :: a -> IO (Maybe a) getOneValue x = getOneSolution (x=:=) --- Returns a list of values that do not satisfy a given constraint. --- @param x - an expression (a generator evaluable to various values) --- @param c - a constraint that should not be satisfied --- @return A list of all values of e such that (c e) is not provable getAllFailures :: a -> (a->Bool) -> IO [a] getAllFailures generator test = do xs <- getAllSolutions (=:=generator) failures <- mapIO (naf test) xs return $ concat failures where -- (naf c x) returns [x] if (c x) fails, and [] otherwise. naf :: (a->Bool) -> a -> IO [a] naf c x = getOneSolution (\_->c x) >>= \mbl-> return (maybe [x] (const []) mbl) --- A search tree for representing search structures. data SearchTree a b = SearchBranch [(b,SearchTree a b)] | Solutions [a] --- Computes a tree of solutions where the first argument determines --- the branching level of the tree. --- For each element in the list of the first argument, --- the search tree contains a branch node with a child tree --- for each value of this element. Moreover, evaluations of --- elements in the branch list are shared within corresponding subtrees. getSearchTree :: [a] -> (b -> Bool) -> IO (SearchTree b a) getSearchTree cs goal = return (getSearchTreeUnsafe cs goal) getSearchTreeUnsafe :: [a] -> (b -> Bool) -> (SearchTree b a) getSearchTreeUnsafe [] goal = Solutions (findall goal) getSearchTreeUnsafe (c:cs) goal = SearchBranch (findall (=:=(solve c cs goal))) solve :: a -> [a] -> (b -> Bool) -> (a,SearchTree b a) solve c cs goal | c=:=y = (y, getSearchTreeUnsafe cs goal) where y free curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/AllSolutions.prim_c2p000066400000000000000000000004401305333611600253130ustar00rootroot00000000000000 prim_standard prim_getOneSolution[raw] curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/AnsiCodes.curry000066400000000000000000000122731305333611600241730ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for formatted output on terminals --- --- Information on ANSI Codes can be found at --- http://en.wikipedia.org/wiki/ANSI_escape_code --- --- @author Sebastian Fischer, Bjoern Peemoeller --- @version March 2015 --- @category general ------------------------------------------------------------------------------ module AnsiCodes ( -- cursor movement cursorPos , cursorHome , cursorUp , cursorDown , cursorFwd , cursorBack , saveCursor , restoreCursor -- graphics control , clear , eraseLine -- formatting output , normal , bold , faint , italic , underline , blinkSlow , blinkRapid , inverse , concealed , crossedout -- foreground color , black , red , green , yellow , blue , cyan , magenta , white , fgDefault -- background color , bgBlack , bgRed , bgGreen , bgYellow , bgBlue , bgCyan , bgMagenta , bgWhite , bgDefault ) where import List (isSuffixOf) -- ----------------------------------------------------------------------------- -- Cursor movement -- ----------------------------------------------------------------------------- --- move cursor to position cursorPos :: Int -> Int -> String cursorPos r c = cmd (show r ++ ";" ++ show c ++ "H") --- move cursor to home position cursorHome :: String cursorHome = cmd "H" --- move cursor n lines up cursorUp :: Int -> String cursorUp = moveCursor "A" --- move cursor n lines down cursorDown :: Int -> String cursorDown = moveCursor "B" --- move cursor n columns forward cursorFwd :: Int -> String cursorFwd = moveCursor "C" --- move cursor n columns backward cursorBack :: Int -> String cursorBack = moveCursor "D" --- save cursor position saveCursor :: String saveCursor = cmd "s" --- restore saved cursor position restoreCursor :: String restoreCursor = cmd "u" -- ----------------------------------------------------------------------------- -- Graphics control -- ----------------------------------------------------------------------------- --- clear screen clear :: String clear = cmd "2J" --- erase line eraseLine :: String eraseLine = cmd "K" -- ----------------------------------------------------------------------------- -- Text formatting -- ----------------------------------------------------------------------------- --- Reset formatting to normal formatting normal :: String -> String normal = mode 0 --- Bold text bold :: String -> String bold = mode 1 --- Faint text faint :: String -> String faint = mode 2 --- Italic text italic :: String -> String italic = mode 3 --- Underlined text underline :: String -> String underline = mode 4 --- Slowly blinking text blinkSlow :: String -> String blinkSlow = mode 5 --- rapidly blinking text blinkRapid :: String -> String blinkRapid = mode 6 --- Inverse colors inverse :: String -> String inverse = mode 7 --- Concealed (invisible) text concealed :: String -> String concealed = mode 8 --- Crossed out text crossedout :: String -> String crossedout = mode 9 -- ----------------------------------------------------------------------------- -- Foreground color -- ----------------------------------------------------------------------------- --- Black foreground color black :: String -> String black = mode 30 --- Red foreground color red :: String -> String red = mode 31 --- Green foreground color green :: String -> String green = mode 32 --- Yellow foreground color yellow :: String -> String yellow = mode 33 --- Blue foreground color blue :: String -> String blue = mode 34 --- Magenta foreground color magenta :: String -> String magenta = mode 35 --- Cyan foreground color cyan :: String -> String cyan = mode 36 --- White foreground color white :: String -> String white = mode 37 --- Default foreground color fgDefault :: String -> String fgDefault = mode 39 -- ----------------------------------------------------------------------------- -- Background color -- ----------------------------------------------------------------------------- --- Black background color bgBlack :: String -> String bgBlack = mode 40 --- Red background color bgRed :: String -> String bgRed = mode 41 --- Green background color bgGreen :: String -> String bgGreen = mode 42 --- Yellow background color bgYellow :: String -> String bgYellow = mode 43 --- Blue background color bgBlue :: String -> String bgBlue = mode 44 --- Magenta background color bgMagenta :: String -> String bgMagenta = mode 45 --- Cyan background color bgCyan :: String -> String bgCyan = mode 46 --- White background color bgWhite :: String -> String bgWhite = mode 47 --- Default background color bgDefault :: String -> String bgDefault = mode 49 -- ----------------------------------------------------------------------------- -- Helper functions -- ----------------------------------------------------------------------------- --- Cursor movements moveCursor :: String -> Int -> String moveCursor s n = cmd (show n ++ s) --- Text mode mode :: Int -> String -> String mode n s = cmd (show n ++ "m") ++ s ++ if end `isSuffixOf` s then "" else end where end = cmd "0m" --- Create a command using the CSI (control sequence introducer) "\ESC[" cmd :: String -> String cmd s = '\ESC' : '[' : s curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Array.curry000066400000000000000000000116441305333611600234020ustar00rootroot00000000000000--- Implementation of Arrays with Braun Trees. Conceptually, Braun trees --- are always infinite. Consequently, there is no test on emptiness. --- --- @authors {bbr, fhu}@informatik.uni-kiel.de --- @category algorithm module Array (Array, emptyErrorArray, emptyDefaultArray, listToDefaultArray,listToErrorArray, (//), update, applyAt, (!), combine, combineSimilar) where import Integer infixl 9 !, // data Array b = Array (Int -> b) (Entry b) data Entry b = Entry b (Entry b) (Entry b) | Empty --- Creates an empty array which generates errors for non-initialized --- indexes. emptyErrorArray :: Array b emptyErrorArray = emptyDefaultArray errorArray errorArray :: Int -> _ errorArray idx = error ("Array index "++show idx++" not initialized") --- Creates an empty array, call given function for non-initialized --- indexes. --- @param default - function to call for each non-initialized index emptyDefaultArray :: (Int -> b) -> Array b emptyDefaultArray dflt = Array dflt Empty --- Inserts a list of entries into an array. --- @param array - array to modify --- @param modifications - list of new (indexes,entries) --- If an index in the list was already initialized, the old value --- will be overwritten. Likewise the last entry with a given index --- will be contained in the result array. (//) :: Array b -> [(Int,b)] -> Array b (//) (Array dflt array) modifications = Array dflt (foldr (\ (n,v) a -> at (dflt n) a n (const v)) array modifications) --- Inserts a new entry into an array. --- @param array - array to modify --- @param idx - index of update --- @param val - value to update at index idx --- Entries already initialized will be overwritten. update :: Array b -> Int -> b -> Array b update (Array dflt a) i v = Array dflt (at (dflt i) a i (const v)) --- Applies a function to an element. --- @param array - array to modify --- @param idx - index of update --- @param fun - function to apply on element at index idx applyAt :: Array b -> Int -> (b->b) -> Array b applyAt (Array dflt a) n f = Array dflt (at (dflt n) a n f) at :: b -> Entry b -> Int -> (b -> b) -> Entry b at dflt Empty n f | n==0 = Entry (f dflt) Empty Empty | odd n = Entry dflt (at dflt Empty (n `div` 2) f) Empty | otherwise = Entry dflt Empty (at dflt Empty (n `div` 2 - 1) f) at dflt (Entry v al ar) n f | n==0 = Entry (f v) al ar | odd n = Entry v (at dflt al (n `div` 2) f) ar | otherwise = Entry v al (at dflt ar (n `div` 2 - 1) f) --- Yields the value at a given position. --- @param a - array to look up in --- @param n - index, where to look (!) :: Array b -> Int -> b (Array dflt array) ! i = from (dflt i) array i from :: a -> Entry a -> Int -> a from dflt Empty _ = dflt from dflt (Entry v al ar) n | n==0 = v | odd n = from dflt al (n `div` 2) | otherwise = from dflt ar (n `div` 2 - 1) split :: [a] -> ([a],[a]) split [] = ([],[]) split [x] = ([x],[]) split (x:y:xys) = let (xs,ys) = split xys in (x:xs,y:ys) --- Creates a default array from a list of entries. --- @param def - default funtion for non-initialized indexes --- @param xs - list of entries listToDefaultArray :: (Int -> b) -> [b] -> Array b listToDefaultArray def = Array def . listToArray --- Creates an error array from a list of entries. --- @param xs - list of entries listToErrorArray :: [b] -> Array b listToErrorArray = listToDefaultArray errorArray listToArray :: [b] -> Entry b listToArray [] = Empty listToArray (x:xs) = let (ys,zs) = split xs in Entry x (listToArray ys) (listToArray zs) --- combine two arbitrary arrays combine :: (a -> b -> c) -> Array a -> Array b -> Array c combine f (Array def1 a1) (Array def2 a2) = Array (\i -> f (def1 i) (def2 i)) (comb f def1 def2 a1 a2 0 1) comb :: (a -> b -> c) -> (Int -> a) -> (Int -> b) -> Entry a -> Entry b -> Int -> Int -> Entry c comb _ _ _ Empty Empty _ _ = Empty comb f def1 def2 (Entry x xl xr) Empty b o = Entry (f x (def2 (b+o-1))) (comb f def1 def2 xl Empty (2*b) o) (comb f def1 def2 xr Empty (2*b) (o+b)) comb f def1 def2 Empty (Entry y yl yr) b o = Entry (f (def1 (b+o-1)) y) (comb f def1 def2 Empty yl (2*b) o) (comb f def1 def2 Empty yr (2*b) (o+b)) comb f def1 def2 (Entry x xl xr) (Entry y yl yr) b o = Entry (f x y) (comb f def1 def2 xl yl (2*b) o) (comb f def1 def2 xr yr (2*b) (o+b)) --- the combination of two arrays with identical default function --- and a combinator which is neutral in the default --- can be implemented much more efficient combineSimilar :: (a -> a -> a) -> Array a -> Array a -> Array a combineSimilar f (Array def a1) (Array _ a2) = Array def (combSim f a1 a2) combSim :: (a -> a -> a) -> Entry a -> Entry a -> Entry a combSim _ Empty a2 = a2 combSim _ (Entry x y z) Empty = Entry x y z combSim f (Entry x xl xr) (Entry y yl yr) = Entry (f x y) (combSim f xl yl) (combSim f xr yr) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Assertion.curry000066400000000000000000000236061305333611600242740ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This module defines the datatype and operations for the --- Curry module tester "currytest". --- --- @author Michael Hanus --- @version May 2014 --- @category general ------------------------------------------------------------------------------ module Assertion(-- for writing test cases: Assertion,assertTrue,assertEqual, assertValues,assertSolutions,assertIO,assertEqualIO, -- the remaining entities are only used by the test tool: checkAssertion, seqStrActions,writeAssertResult, ProtocolMsg(..), showTestMod,showTestCase,showTestEnd,showTestCompileError) where import AllSolutions import List((\\)) import Socket -- for sending results to test GUI import IO(hPutStrLn,hClose) import Distribution(curryCompiler) infixl 1 `seqStrActions` --- Datatype for defining test cases. --- @cons AssertTrue s b - assert (with name s) that b must be true --- @cons AssertEqual s e1 e2 - assert (with name s) that e1 and e2 must --- be equal (w.r.t. ==) --- @cons AssertValues s e vs - assert (with name s) that vs is the multiset --- of all values of e (i.e., all values of e are --- compared with the elements in vs w.r.t. ==) --- @cons AssertSolutions s c vs - assert (with name s) that constraint --- abstraction c has the multiset of solutions vs --- (i.e., the solutions of c are compared with the elements in vs w.r.t. ==) --- @cons AssertIO s a r - assert (with name s) that I/O action a --- yields the result value r --- @cons AssertEqualIO s a1 a2 - assert (with name s) that I/O actions a1 and --- a2 yield equal (w.r.t. ==) results data Assertion a = AssertTrue String Bool | AssertEqual String a a | AssertValues String a [a] | AssertSolutions String (a->Bool) [a] | AssertIO String (IO a) a | AssertEqualIO String (IO a) (IO a) --- `(assertTrue s b)` asserts (with name `s`) that `b` must be true. assertTrue :: String -> Bool -> Assertion () assertTrue s b = AssertTrue s b --- `(assertEqual s e1 e2)` asserts (with name `s`) that `e1` and `e2` --- must be equal (w.r.t. `==`). assertEqual :: String -> a -> a -> Assertion a assertEqual s x y = AssertEqual s x y --- `(assertValues s e vs)` asserts (with name `s`) that `vs` is the multiset --- of all values of `e`. All values of `e` are --- compared with the elements in `vs` w.r.t. `==`. assertValues :: String -> a -> [a] -> Assertion a assertValues s x y = AssertValues s x y --- `(assertSolutions s c vs)` asserts (with name `s`) that constraint --- abstraction `c` has the multiset of solutions `vs`. --- The solutions of `c` are compared with the elements in `vs` w.r.t. `==`. assertSolutions :: String -> (a->Bool) -> [a] -> Assertion a assertSolutions s x y = AssertSolutions s x y --- `(assertIO s a r)` asserts (with name `s`) that I/O action `a` --- yields the result value `r`. assertIO :: String -> IO a -> a -> Assertion a assertIO s x y = AssertIO s x y --- `(assertEqualIO s a1 a2)` asserts (with name `s`) that I/O actions `a1` --- and `a2` yield equal (w.r.t. `==`) results. assertEqualIO :: String -> IO a -> IO a -> Assertion a assertEqualIO s x y = AssertEqualIO s x y --- Combines two actions and combines their results. --- Used by the currytest tool. seqStrActions :: IO (String,Bool) -> IO (String,Bool) -> IO (String,Bool) seqStrActions a1 a2 = do (s1,b1) <- a1 (s2,b2) <- a2 return (s1++s2,b1&&b2) --- Executes and checks an assertion, and process the result --- by an I/O action. --- Used by the currytest tool. --- @param protocol - an action to be applied after test execution --- @param assertion - an assertion to be tested --- @return a protocol string and a flag whether the test was successful checkAssertion :: String -> ((String,Bool) -> IO (String,Bool)) -> Assertion _ -> IO (String,Bool) checkAssertion asrtop prot assrt = catchNDIO asrtop prot (execAsrt assrt) where execAsrt (AssertTrue name cond) = catch (checkAssertTrue name cond) (returnError name) >>= prot execAsrt (AssertEqual name call result) = catch (checkAssertEqual name call result) (returnError name) >>= prot execAsrt (AssertValues name expr results) = catch (checkAssertValues name expr results) (returnError name) >>= prot execAsrt (AssertSolutions name constr results) = catch (checkAssertSolutions name constr results) (returnError name) >>= prot execAsrt (AssertIO name action result) = catch (checkAssertIO name action result) (returnError name) >>= prot execAsrt (AssertEqualIO name action1 action2) = catch (checkAssertEqualIO name action1 action2) (returnError name) >>= prot returnError name err = return ("FAILURE of "++name++": "++showError err++"\n",False) -- Execute I/O action for assertion checking and report any failure -- or non-determinism. catchNDIO :: String -> ((String,Bool) -> IO (String,Bool)) -> IO (String,Bool) -> IO (String,Bool) catchNDIO fname prot a = if curryCompiler == "kics2" then -- specific handling for KiCS2 since it might report non-det errors -- even if there is only one result value, e.g., in functional patterns getAllValues a >>= checkIOActions else catch a (\e -> prot ("ERROR in "++fname++": "++showError e++"\n",False)) where checkIOActions results | null results = prot ("ERROR in "++fname++": computation failed\n",False) | not (null (tail results)) = prot ("ERROR in "++fname++ ": computation is non-deterministic\n",False) | otherwise = head results -- Checks Boolean assertion. checkAssertTrue :: String -> Bool -> IO (String,Bool) checkAssertTrue name cond = catchNDIO name return $ if cond then return ("OK: "++name++"\n",True) else return ("FAILURE of "++name++": assertion not satisfied:\n",False) -- Checks equality assertion. checkAssertEqual :: String -> a -> a -> IO (String,Bool) checkAssertEqual name call result = catchNDIO name return $ if call==result then return ("OK: "++name++"\n",True) else return ("FAILURE of "++name++": equality assertion not satisfied:\n"++ "Computed answer: "++show call++"\n"++ "Expected answer: "++show result++"\n",False) -- Checks all values assertion. checkAssertValues :: String -> a -> [a] -> IO (String,Bool) checkAssertValues name call results = do rs <- getAllValues call if null (rs \\ results) && null (results \\ rs) then return ("OK: "++name++"\n",True) else return ("FAILURE of "++name++": values assertion not satisfied:\n"++ "Computed values: "++show rs++"\n"++ "Expected values: "++show results++"\n",False) -- Checks all solutions of a constraint abstraction. checkAssertSolutions :: String -> (a->Bool) -> [a] -> IO (String,Bool) checkAssertSolutions name constr results = do rs <- getAllSolutions constr if null (rs \\ results) && null (results \\ rs) then return ("OK: "++name++"\n",True) else return ("FAILURE of "++name++": solutions assertion not satisfied:\n"++ "Computed values: "++show rs++"\n"++ "Expected values: "++show results++"\n",False) -- Checks an IO assertion. checkAssertIO :: String -> IO a -> a -> IO (String,Bool) checkAssertIO name action result = do r <- action if r==result then return ("OK: "++name++"\n",True) else return ("FAILURE of "++name++": IO assertion not satisfied:\n"++ "Computed answer: "++show r++"\n"++ "Expected answer: "++show result++"\n\n",False) -- Checks equality of results of two IO assertions. checkAssertEqualIO :: String -> IO a -> IO a -> IO (String,Bool) checkAssertEqualIO name action1 action2 = do r1 <- action1 r2 <- action2 if r1==r2 then return ("OK: "++name++"\n",True) else return ("FAILURE of "++name++": IO equality assertion not satisfied:\n"++ "Computed answer 1: "++show r1++"\n"++ "Computed answer 2: "++show r2++"\n\n",False) --- Prints the results of assertion checking. --- If failures occurred, the return code is positive. --- Used by the currytest tool. writeAssertResult :: (String,Bool) -> IO Int writeAssertResult (result,flag) = if flag then putStrLn (result++"All tests successfully passed.") >> return 0 else putStrLn (result++"FAILURE occurred in some assertions!\n") >> return 1 ---------------------------------------------------------------------------- -- The following entities are used to implement the test GUI: --- The messages sent to the test GUI. --- Used by the currytest tool. data ProtocolMsg = TestModule String | TestCase String Bool | TestFinished | TestCompileError --- Sends message to GUI for showing test of a module. --- Used by the currytest tool. showTestMod :: Int -> String -> IO () showTestMod portnum modname = sendToLocalSocket portnum (TestModule modname) --- Sends message to GUI for showing result of executing a test case. --- Used by the currytest tool. showTestCase :: Int -> (String,Bool) -> IO (String,Bool) showTestCase portnum (s,b) = do sendToLocalSocket portnum (TestCase s b) return (s,b) --- Sends message to GUI for showing end of module test. --- Used by the currytest tool. showTestEnd :: Int -> IO () showTestEnd portnum = sendToLocalSocket portnum TestFinished --- Sends message to GUI for showing compilation errors in a module test. --- Used by the currytest tool. showTestCompileError :: Int -> IO () showTestCompileError portnum = sendToLocalSocket portnum TestCompileError --- Sends protocol message to local socket. sendToLocalSocket :: Int -> ProtocolMsg -> IO () sendToLocalSocket portnum msg = do h <- connectToSocket "localhost" portnum hPutStrLn h (show msg) hClose h -- end of module Assertion curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Bootstrap3Style.curry000066400000000000000000000220171305333611600254010ustar00rootroot00000000000000---------------------------------------------------------------------------- --- This library contains some operations to generate web pages --- rendered with [Bootstrap](http://twitter.github.com/bootstrap/) --- --- @author Michael Hanus --- @version January 2016 --- @category web ---------------------------------------------------------------------------- module Bootstrap3Style ( bootstrapForm, bootstrapPage, titledSideMenu , defaultButton, smallButton, primButton , hrefButton, hrefBlock, hrefInfoBlock , glyphicon, homeIcon, userIcon, loginIcon, logoutIcon ) where import HTML ---------------------------------------------------------------------------- --- An HTML form rendered with bootstrap. --- @param rootdir - the root directory to find styles (in subdirectory `css` --- of the root) and images (in subdirectory `img` of the root) --- @param styles - the style files to be included (typically, --- `bootstrap` and `bootstrap-responsive`), stored in --- `rootdir/css` with suffix `.css`) --- @param title - the title of the form --- @param brandurltitle - the URL and contents shown as the brand of the page --- @lefttopmenu - the menu shown in the left side of the top navigation bar --- @righttopmenu - the menu shown in the right side of the top navigation bar --- (could be empty) --- @param columns - number of columns for the left-side menu --- (if columns==0, then the left-side menu is omitted) --- @param sidemenu - the menu shown at the left-side of the main document --- (maybe created with 'titledSideMenu') --- @param header - the main header (rendered with jumbotron style) --- @param contents - the main contents of the document --- @param footer - the footer of the document bootstrapForm :: String -> [String] -> String -> (String,[HtmlExp]) -> [[HtmlExp]] -> [[HtmlExp]] -> Int -> [HtmlExp] -> [HtmlExp] -> [HtmlExp] -> [HtmlExp] -> HtmlForm bootstrapForm rootdir styles title brandurltitle lefttopmenu righttopmenu leftcols sidemenu header contents footer = HtmlForm title ([formEnc "utf-8", responsiveView, icon] ++ map (\n -> formCSS (rootdir++"/css/"++n++".css")) styles) (bootstrapBody rootdir brandurltitle lefttopmenu righttopmenu leftcols sidemenu header contents footer) where -- for a better view on handheld devices: responsiveView = HeadInclude (HtmlStruct "meta" [("name","viewport"), ("content","width=device-width, initial-scale=1.0")] []) icon = HeadInclude (HtmlStruct "link" [("rel","shortcut icon"), ("href",rootdir++"/img/favicon.ico")] []) --- An HTML page rendered with bootstrap. --- @param rootdir - the root directory to find styles, fonts, scripts --- (in subdirectories `css`, `fonts`, `js`) and the --- `favicon.ico` --- of the root) and images (in subdirectory `img` of the root) --- @param styles - the style files to be included (typically, --- `bootstrap` and `bootstrap-responsive`), stored in --- `rootdir/css` with suffix `.css`) --- @param title - the title of the form --- @lefttopmenu - the menu shown in the left side of the top navigation bar --- @righttopmenu - the menu shown in the right side of the top navigation bar --- (could be empty) --- @param columns - number of columns for the left-side menu --- (if columns==0, then the left-side menu is omitted) --- @param sidemenu - the menu shown at the left-side of the main document --- (maybe created with 'titledSideMenu') --- @param header - the main header (rendered with jumbotron style) --- @param contents - the main contents of the document --- @param footer - the footer of the document bootstrapPage :: String -> [String] -> String -> (String,[HtmlExp]) -> [[HtmlExp]] -> [[HtmlExp]] -> Int -> [HtmlExp] -> [HtmlExp] -> [HtmlExp] -> [HtmlExp] -> HtmlPage bootstrapPage rootdir styles title brandurltitle lefttopmenu righttopmenu leftcols sidemenu header contents footer = HtmlPage title ([pageEnc "utf-8",responsiveView,icon] ++ map (\n -> pageCSS (rootdir++"/css/"++n++".css")) styles) (bootstrapBody rootdir brandurltitle lefttopmenu righttopmenu leftcols sidemenu header contents footer) where -- for a better view on handheld devices: responsiveView = pageMetaInfo [("name","viewport"), ("content","width=device-width, initial-scale=1.0")] icon = pageLinkInfo [("rel","shortcut icon"), ("href",rootdir++"/favicon.ico")] --- Create body of HTML page. Used by bootstrapForm and bootstrapPage. bootstrapBody :: String -> (String,[HtmlExp]) -> [[HtmlExp]] -> [[HtmlExp]] -> Int -> [HtmlExp] -> [HtmlExp] -> [HtmlExp] -> [HtmlExp] -> [HtmlExp] bootstrapBody rootdir brandurltitle lefttopmenu righttopmenu leftcols sidemenu header contents footer = topNavigationBar brandurltitle lefttopmenu righttopmenu ++ [blockstyle "container-fluid" ([blockstyle "row" (if leftcols==0 then [blockstyle (bsCols 12) (headerRow ++ contents)] else [blockstyle (bsCols leftcols) [blockstyle "well nav-sidebar" sidemenu], blockstyle (bsCols (12-leftcols)) (headerRow ++ contents)])] ++ if null footer then [] else [hrule, HtmlStruct "footer" [] footer]), -- JavaScript includes placed at the end so page loads faster: HtmlStruct "script" [("src",rootdir++"/js/jquery.min.js")] [], HtmlStruct "script" [("src",rootdir++"/js/bootstrap.min.js")] []] where bsCols n = "col-sm-" ++ show n ++ " " ++ "col-md-" ++ show n -- header row: headerRow = if null header then [] else [HtmlStruct "header" [("class","jumbotron")] header] -- Navigation bar at the top. The first argument is a header element -- put at the left, the second and third arguments are the left -- and right menus which will be collapsed if the page is two small. topNavigationBar :: (String,[HtmlExp]) -> [[HtmlExp]] -> [[HtmlExp]] -> [HtmlExp] topNavigationBar (brandurl,brandtitle) leftmenu rightmenu = [blockstyle "navbar navbar-inverse navbar-fixed-top" [blockstyle "container-fluid" [blockstyle "navbar-header" [HtmlStruct "button" [("type","button"),("class","navbar-toggle collapsed"), ("data-toggle","collapse"),("data-target","#topnavbar"), ("aria-expanded","false"),("aria-controls","topnavbar")] [textstyle "sr-only" "Toggle navigation", textstyle "icon-bar" "", textstyle "icon-bar" "", textstyle "icon-bar" ""], href brandurl brandtitle `addClass` "navbar-brand"], HtmlStruct "div" [("id","topnavbar"), ("class","collapse navbar-collapse")] ([ulist leftmenu `addClass` "nav navbar-nav"] ++ if null rightmenu then [] else [ulist rightmenu `addClass` "nav navbar-nav navbar-right"])]]] -- Create a side menu containing a title and a list of items: titledSideMenu :: String -> [[HtmlExp]] -> [HtmlExp] titledSideMenu title items = (if null title then [] else [HtmlStruct "small" [] [htxt title]]) ++ [ulist items `addClass` "nav nav-sidebar"] ---------------------------------------------------------------------------- -- Some buttons: --- Default input button. defaultButton :: String -> HtmlHandler -> HtmlExp defaultButton label handler = button label handler `addClass` "btn btn-default" --- Small input button. smallButton :: String -> HtmlHandler -> HtmlExp smallButton label handler = button label handler `addClass` "btn btn-sm btn-default" --- Primary input button. primButton :: String -> HtmlHandler -> HtmlExp primButton label handler = button label handler `addClass` "btn btn-primary" --- Hypertext reference rendered as a button. hrefButton :: String -> [HtmlExp] -> HtmlExp hrefButton ref hexps = href ref hexps `addClass` "btn btn-sm btn-default" --- Hypertext reference rendered as a block level button. hrefBlock :: String -> [HtmlExp] -> HtmlExp hrefBlock ref hexps = href ref hexps `addClass` "btn btn-sm btn-block" --- Hypertext reference rendered as an info block level button. hrefInfoBlock :: String -> [HtmlExp] -> HtmlExp hrefInfoBlock ref hexps = href ref hexps `addClass` "btn btn-info btn-block" ---------------------------------------------------------------------------- -- Some icons: glyphicon :: String -> HtmlExp glyphicon n = textstyle ("glyphicon glyphicon-"++n) "" homeIcon :: HtmlExp homeIcon = glyphicon "home" userIcon :: HtmlExp userIcon = glyphicon "user" loginIcon :: HtmlExp loginIcon = glyphicon "log-in" logoutIcon :: HtmlExp logoutIcon = glyphicon "log-out" ---------------------------------------------------------------------------- curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/CHR.curry.pakcs000066400000000000000000000677511305333611600240520ustar00rootroot00000000000000---------------------------------------------------------------------- --- A representation of CHR rules in Curry, an interpreter --- for CHR rules based on the refined operational semantics of --- Duck et al. (ICLP 2004), and a compiler into CHR(Prolog). --- --- To use CHR(Curry), specify the CHR(Curry) rules in a Curry program, --- load it, add module `CHR` and interpret or compile the rules --- with `runCHR` or `compileCHR`, respectively. This can be done --- in one shot with --- --- > pakcs :l MyRules :add CHR :eval 'compileCHR "MyCHR" [rule1,rule2]' :q --- --- @author Michael Hanus --- @version May 2016 --- @category general ---------------------------------------------------------------------- {-# OPTIONS_CYMAKE -Wno-incomplete-patterns -Wno-overlapping #-} module CHR(CHR,Goal,(/\), (<=>), (==>), (|>), (\\), true, fail, andCHR, allCHR, chrsToGoal, toGoal1, toGoal2, toGoal3, toGoal4, toGoal5, toGoal6, (.=.), (./=.), (.<=.), (.>=.), (.>.), (.<.), nonvar, ground, anyPrim, solveCHR, runCHR, runCHRwithTrace, compileCHR, chr2curry ) where import Char import Findall (rewriteSome) import FlatCurry.Types import FlatCurry.Files import FlatCurry.Goodies import FlatCurry.Pretty (defaultOptions, ppTypeExp) import List import Prolog import Pretty (pretty) import SetRBT import Unsafe -- for tracing import XML ------------------------------------------------------------------------------- -- Operator definitions for writing CHRs: infix 5 .=., ./=., .<=., .>=., .>., .<. infixr 4 /\ infix 3 <=> infix 3 ==> infix 2 \\ infix 1 |> ------------------------------------------------------------------------------- -- Data types for defining Constraint Handling Rules. --- The basic data type of Constraint Handling Rules. data CHR dom chr = SimplRule [chr] [PrimConstraint dom] (Goal dom chr) | PropaRule [chr] [PrimConstraint dom] (Goal dom chr) | SimpaRule [chr] [chr] [PrimConstraint dom] (Goal dom chr) --- Simplification rule. (<=>) :: Goal dom chr -> Goal dom chr -> CHR dom chr g1 <=> g2 = if null (primsOfGoal g1) then SimplRule (uchrOfGoal g1) [] g2 else error "Rule with primitive constraint on the left-hand side!" --- Propagation rule. (==>) :: Goal dom chr -> Goal dom chr -> CHR dom chr g1 ==> g2 = if null (primsOfGoal g1) then PropaRule (uchrOfGoal g1) [] g2 else error "Rule with primitive constraint on the left-hand side!" --- Simpagation rule: if rule is applicable, the first constraint is kept --- and the second constraint is deleted. (\\) :: Goal dom chr -> CHR dom chr -> CHR dom chr g1 \\ (SimplRule lchrs guard rcs) | not (null (primsOfGoal g1)) = error "Simpagation rule with primitive kept constraints!" | null keptcs -- to omit trivial uses of simpagation rule = SimplRule lchrs guard rcs | null lchrs -- to omit trivial uses of simpagation rule = PropaRule keptcs guard rcs | otherwise = SimpaRule keptcs lchrs guard rcs where keptcs = uchrOfGoal g1 --- A rule with a guard. (|>) :: CHR dom chr -> Goal dom chr -> CHR dom chr rule |> g3 = attachGuard rule where attachGuard (SimplRule lcs guard rcs) = if null (uchrOfGoal rcs) then SimplRule lcs (guard ++ primsOfGoal rcs) g3 else error "Rule contains a guard with non-primitive constraints!" attachGuard (PropaRule lcs guard rcs) = if null (uchrOfGoal rcs) then PropaRule lcs (guard ++ primsOfGoal rcs) g3 else error "Rule contains a guard with non-primitive constraints!" attachGuard (SimpaRule h1 h2 guard rcs) = if null (uchrOfGoal rcs) then SimpaRule h1 h2 (guard ++ primsOfGoal rcs) g3 else error "Rule contains a guard with non-primitive constraints!" ------------------------------------------------------------------------------ -- Data types for defining CHR goals and constraints. --- A CHR constraint is either a primitive or a user-defined constraint. data CHRconstr dom chr = PrimCHR (PrimConstraint dom) | UserCHR chr --- A CHR goal is a list of CHR constraints (primitive or user-defined). data Goal dom chr = Goal [CHRconstr dom chr] --- Conjunction of CHR goals. (/\) :: Goal dom chr -> Goal dom chr -> Goal dom chr (/\) (Goal c1) (Goal c2) = Goal (c1 ++ c2) --- The always satisfiable CHR constraint. true :: Goal dom chr true = Goal [] --- The always failing constraint. fail :: Goal dom chr fail = primToGoal Fail --- Join a list of CHR goals into a single CHR goal (by conjunction). andCHR :: [Goal dom chr] -> Goal dom chr andCHR = foldr (/\) true --- Is a given constraint abstraction satisfied by all elements in a list? allCHR :: (a -> Goal dom chr) -> [a] -> Goal dom chr allCHR fc = andCHR . map fc -- Extracts the list of user-defined constraints contained in a CHR goal. uchrOfGoal :: Goal dom chr -> [chr] uchrOfGoal (Goal cs) = concatMap uchr cs where uchr (PrimCHR _) = [] uchr (UserCHR c) = [c] -- Extracts the list of primitive constraints contained in a CHR goal. primsOfGoal :: Goal dom chr -> [PrimConstraint dom] primsOfGoal (Goal cs) = concatMap prim cs where prim (PrimCHR c) = [c] prim (UserCHR _) = [] --- Transforms a list of CHR constraints into a CHR goal. chrsToGoal :: [chr] -> Goal dom chr chrsToGoal cs = Goal (map UserCHR cs) --- Transform unary CHR constraint into a CHR goal. toGoal1 :: (a -> chr) -> a -> Goal dom chr toGoal1 c x = Goal [UserCHR (c x)] --- Transforms binary CHR constraint into a CHR goal. toGoal2 :: (a -> b -> chr) -> a -> b -> Goal dom chr toGoal2 c x y = Goal [UserCHR (c x y)] --- Transforms a ternary CHR constraint into a CHR goal. toGoal3 :: (a -> b -> c -> chr) -> a -> b -> c -> Goal dom chr toGoal3 c x y z = Goal [UserCHR (c x y z)] --- Transforms a CHR constraint of arity 4 into a CHR goal. toGoal4 :: (a -> b -> c -> d -> chr) -> a -> b -> c -> d -> Goal dom chr toGoal4 con a b c d = Goal [UserCHR (con a b c d)] --- Transforms a CHR constraint of arity 5 into a CHR goal. toGoal5 :: (a -> b -> c -> d -> e -> chr) -> a -> b -> c -> d -> e -> Goal dom chr toGoal5 con a b c d e = Goal [UserCHR (con a b c d e)] --- Transforms a CHR constraint of arity 6 into a CHR goal. toGoal6 :: (a -> b -> c -> d -> e -> f -> chr) -> a -> b -> c -> d -> e -> f -> Goal dom chr toGoal6 con a b c d e f = Goal [UserCHR (con a b c d e f)] ----------------------------------------------------------------------------- -- Primitive constraints: data PrimConstraint a = Eq a a -- equality | Neq a a -- disequality | Fail -- always unsatisfiable | Compare (a -> a -> Bool) a a -- ordering constraint | Ground a -- ground value | Nonvar a -- not an unbound variable | AnyPrim (() -> Bool) -- user-defined primitive --- Transforms a primitive constraint into a CHR goal. primToGoal :: PrimConstraint dom -> Goal dom chr primToGoal pc = Goal [PrimCHR pc] --- Primitive syntactic equality on arbitrary terms. (.=.) :: dom -> dom -> Goal dom chr x .=. y = primToGoal (Eq x y) --- Primitive syntactic disequality on ground(!) terms. (./=.) :: dom -> dom -> Goal dom chr x ./=. y = primToGoal (Neq x y) --- Primitive less-or-equal constraint. (.<=.) :: dom -> dom -> Goal dom chr x .<=. y = primToGoal (Compare (<=) x y) --- Primitive greater-or-equal constraint. (.>=.) :: dom -> dom -> Goal dom chr x .>=. y = primToGoal (Compare (>=) x y) --- Primitive less-than constraint. (.<.) :: dom -> dom -> Goal dom chr x .<. y = primToGoal (Compare (<) x y) --- Primitive greater-than constraint. (.>.) :: dom -> dom -> Goal dom chr x .>. y = primToGoal (Compare (>) x y) --- Primitive groundness constraint (useful for guards). ground :: dom -> Goal dom chr ground x = primToGoal (Ground x) --- Primitive nonvar constraint (useful for guards). nonvar :: dom -> Goal dom chr nonvar x = primToGoal (Nonvar x) --- Embed user-defined primitive constraint. anyPrim :: (() -> Bool) -> Goal dom chr anyPrim cf = primToGoal (AnyPrim cf) -- Evaluate primitive constraints. evalPrimCHR :: PrimConstraint _ -> Bool evalPrimCHR (Eq x y) = x=:=y evalPrimCHR (Neq x y) = (x==y) =:= False evalPrimCHR Fail = failed evalPrimCHR (Compare cmp x y) = (cmp x y) =:= True evalPrimCHR (Nonvar x) = Unsafe.isVar x =:= False evalPrimCHR (Ground x) = Unsafe.isGround x =:= True evalPrimCHR (AnyPrim cf) = cf () ------------------------------------------------------------------------------ -- Interpreter for CHR constraints ------------------------------------------------------------------------------ --- Interpret CHR rules (parameterized over domain variables) --- for a given CHR goal (second argument) and embed this as --- a constraint solver in Curry. If user-defined CHR constraints remain --- after applying all CHR rules, a warning showing the residual --- constraints is issued. solveCHR :: [[dom] -> CHR dom chr] -> Goal dom chr -> Bool solveCHR prules goal = let residual = runCHR prules goal in if null residual then True else trace ("WARNING: residual CHR constraints: "++show residual++"\n") True ------------------------------------------------------------------------ -- The structure and operations for the history of the interpreter. -- type History = [([Int],Int)] -- entry: constraint indices and rule index -- emptyHistory = [] -- extendHistory = (:) -- inHistory = elem type History = SetRBT ([Int],Int) -- entry: constraint indices and rule index emptyHistory :: SetRBT a emptyHistory = emptySetRBT (<=) extendHistory :: a -> SetRBT a -> SetRBT a extendHistory = insertRBT inHistory :: a -> SetRBT a -> Bool inHistory = elemRBT ------------------------------------------------------------------------ --- Interpret CHR rules (parameterized over domain variables) --- for a given CHR goal (second argument) and return the remaining --- CHR constraints. runCHR :: [[dom] -> CHR dom chr] -> Goal dom chr -> [chr] runCHR prules goal = evalCHR False prules goal --- Interpret CHR rules (parameterized over domain variables) --- for a given CHR goal (second argument) and return the remaining --- CHR constraints. Trace also the active and passive constraints --- as well as the applied rule number during computation. runCHRwithTrace :: [[dom] -> CHR dom chr] -> Goal dom chr -> [chr] runCHRwithTrace prules goal = evalCHR True prules goal -- Interpreter for CHR (refined semantics): evalCHR :: Bool -> [[dom] -> CHR dom chr] -> Goal dom chr -> [chr] evalCHR withtrace urules (Goal goal) | evalConstr gidx emptyHistory chrgoal [] result = map snd result where tracing s = if withtrace then trace s else id result free rules = zip [1..] urules (gidx,chrgoal) = numberCHR 0 goal solvePrims = all evalPrimCHR -- evaluate list of active constraints: evalConstr gi hist gl cstore finalcs = tracing (showAnyTerm (gl,cstore)) $ evalC gl cstore finalcs where evalC [] cs rcs = cs =:= rcs -- no active constraints left to work on evalC (PrimCHR pc : gs) cs rcs = -- awake all passive constraints: tracing ("Evaluate primitive: " ++ showAnyTerm pc) $ evalPrimCHR pc & evalConstr gi hist (map UserCHR cs ++ gs) [] rcs evalC (UserCHR c : gs) cs rcs = (normalForm c) -- necessary to evaluate functions in c's arguments `seq` tryRules gi hist rules c gs cs rcs -- try to apply CHR rules in sequential order to first active constraint: tryRules gi hs [] c gs cs rcs = -- no CHR rule applicable, try solve a prim: maybe (tracing "Suspend constraint" $ evalConstr gi hs gs (c:cs) rcs) -- suspend first active constraint (\ (pc,mgs) -> tracing ("Evaluate primitive: " ++ showAnyTerm pc) $ evalPrimCHR pc & -- awake all passive constraints: evalConstr gi hs (map UserCHR (c:cs) ++ mgs) [] rcs) (extractPrim gs) tryRules gi hist ((ri,r) : rs) c gs cs rcs = maybe (tryRules gi hist rs c gs cs rcs) (\ (newcs,newgs,remcs,is) -> if (is,ri) `inHistory` hist -- rule already applied? then tryRules gi hist rs c gs cs rcs else --trace (show (is,ri)) $ let (gj,inewcs) = numberCHR gi newcs in tracing ("Apply rule " ++ show ri) $ evalConstr gj (if null is then hist else extendHistory (is,ri) hist) (inewcs++newgs) remcs rcs) (rewriteSome (applyRule (r unknown) c gs cs)) -- Apply a CHR rule to an active constraint and constraint store -- and return the new goal, remaining constraint store and indices -- of the CHR constraints matched for the left-hand side, if it is -- a propogation rule (in this case, it is stored in the history to -- avoid re-application of the same rule). applyRule (SimplRule lchrs guard (Goal rchrs)) (_,c) gs cs | deleteSome c lchrs =:= lhs & findDelete lhs cs =:= (delcs,remcs) &> solvePrims guard = (rchrs,gs,remcs,[]) where lhs,delcs,remcs free applyRule (PropaRule lchrs guard (Goal rchrs)) (i,c) gs cs | deleteSome c lchrs =:= lhs & findDelete lhs cs =:= (delcs,_) &> solvePrims guard = (rchrs, UserCHR (i,c) : gs, cs, i : map fst delcs) where lhs,delcs free applyRule (SimpaRule kept lchrs guard (Goal rchrs)) (_,c) gs cs | deleteSome c lchrs =:= lhs & findDelete (kept++lhs) cs =:= (delcs,remcs) &> solvePrims guard = (rchrs, gs, take (length kept) delcs ++ remcs, []) where lhs,delcs,remcs free applyRule (SimpaRule kept lchrs guard (Goal rchrs)) (i,c) gs cs | deleteSome c kept =:= kc & findDelete (kc++lchrs) cs =:= (delcs,remcs) &> solvePrims guard = (rchrs, UserCHR (i,c) : gs, take (length kc) delcs ++ remcs, []) where kc,delcs,remcs free -- Auxiliary operations: -- Find a list of elements in another list and return the remaining ones: findDelete :: [a] -> [(Int,a)] -> ([(Int,a)],[(Int,a)]) findDelete [] cs = ([],cs) findDelete (x:xs) cs = let (z,ds) = del x cs (zs,es) = findDelete xs ds in (z:zs,es) where del e (z:zs) | e=:=snd z = (z,zs) del e (z:zs) = let (y,ys) = del e zs in (y, z:ys) deleteSome :: a -> [a] -> [a] deleteSome e (z:zs) | e=:=z = zs deleteSome e (z:zs) = z : deleteSome e zs -- Finds and deletes the first primitive constraint in a CHR goal: extractPrim :: [CHRconstr dom chr] -> Maybe (PrimConstraint dom, [CHRconstr dom chr]) extractPrim [] = Nothing extractPrim (PrimCHR pc : cs) = Just (pc, cs) extractPrim (UserCHR c : cs) = maybe Nothing (\ (pc,rcs) -> Just (pc, UserCHR c : rcs)) (extractPrim cs) -- Add a unique number to each CHR constraint. numberCHR :: Int -> [CHRconstr dom chr] -> (Int, [CHRconstr dom (Int,chr)]) numberCHR i [] = (i,[]) numberCHR i (PrimCHR pc : cs) = let (j,ics) = numberCHR i cs in (j, PrimCHR pc : ics) numberCHR i (UserCHR c : cs) = let (j,ics) = numberCHR (i+1) cs in (j, UserCHR (i,c) : ics) ---------------------------------------------------------------------- -- Compiler from Curry CHR rules into CHR(Prolog) rules where -- operations from the Curry program can also be called from the -- CHR(Prolog) code. --- Compile a list of CHR(Curry) rules into CHR(Prolog) and store its interface --- in a Curry program (name given as first argument). compileCHR :: String -> [[dom] -> CHR dom chr] -> IO () compileCHR currymod rules | null rids = putStrLn "No CHR rules to compile." | any (/=sourcemodname) (map fst rids) = error "Cannot compile CHR rules from different modules!" | otherwise = compileRules sourcemodname currymod (map snd rids) where rids = map ruleId rules sourcemodname = fst (head rids) -- extract the qualified name of a rule: ruleId :: ([dom] -> CHR dom chr) -> QName ruleId rule = let rcallstring = showAnyQExpression rule -- "(partcall 1 qid [])" qid = takeWhile (not . isSpace) (drop (length "(partcall 1 ") rcallstring) (mname,rname) = break (=='.') qid in (mname, tail rname) -- compile all specifed CHR rules to CHR(Prolog): compileRules :: String -> String -> [String] -> IO () compileRules modname chrmodname rids = do (Prog _ _ _ fdecls opdecls) <- readFlatCurry modname let pmodname = chrmodname++"_prim" getftype = getFuncType fdecls rdefs = filter (\ (Func fname _ _ _ _) -> snd fname `elem` rids) fdecls (chrs,_) = unzip (map (compileRule getftype []) (map funcRule rdefs)) allchrs = nub (concat chrs) (_,trules) = unzip (map (compileRule getftype allchrs) (map funcRule rdefs)) allchrtypes = zip allchrs (map getftype (map fst allchrs)) curryprog = showCHRModule modname chrmodname opdecls allchrtypes prologprog = unlines $ map showPlClause ([PlDirective [PlLit "module" [PlAtom pmodname, plList (map (\ (qcname,carity)-> PlStruct "/" [PlAtom (showCName ("prim_"++snd qcname)), PlInt (carity+1)]) allchrs)]], PlDirective [PlLit "use_module" [PlStruct "library" [PlAtom "chr"]]]] ++ map (\ (p,a) -> PlDirective [PlLit "chr_constraint" [PlStruct "/" [PlAtom (showQName p), PlInt a]]]) allchrs) ++ ["","% CHR rules:"] ++ trules ++ ["","% Curry/Prolog interface:"] ++ map (showPlClause . chrPrologPrimDefinition) allchrs ++ ["","% Auxiliary predicates:", "sunif(X,Y) :- user:evalToken(E), user:hnf('Prelude.=:='(X,Y),_,E,_).", "eval(X) :- user:evalToken(E), user:hnf(X,_,E,_)."] writeFile (chrmodname++".curry") curryprog writeXmlFileWithParams (chrmodname++".prim_c2p") [DtdUrl "http://www.informatik.uni-kiel.de/~pakcs/primitives.dtd"] (constraints2xml pmodname allchrs) writeFile (pmodname++".pl") prologprog --putStrLn curryprog --putStrLn prologprog putStrLn $ "Curry interface to CHR(Prolog) written to "++chrmodname++".curry" getFuncType :: [FuncDecl] -> (String,String) -> TypeExpr getFuncType fdecls qfname = maybe (error $ showQName qfname ++ " not found!") funcType (find (\ (Func qf _ _ _ _) -> qf == qfname) fdecls) chrPrologPrimDefinition :: (QName,Int) -> PlClause chrPrologPrimDefinition (qcname,carity) = PlClause (showCName ("prim_"++snd qcname)) (map PlVar (map (\i->"X"++show i) [1..carity] ++ ["R"])) [PlLit (showQName qcname) (map (\i->PlVar ("X"++show i)) [1..carity]), PlLit "=" [PlVar "R", PlAtom "Prelude.True"]] -- show Curry module as interface to CHR solver implemented in Prolog: showCHRModule :: String -> String -> [OpDecl] -> [((QName,Int),TypeExpr)] -> String showCHRModule orgmod chrmod opdecls constraints = unlines $ ["module "++chrmod++exports++" where","", -- import original modules so that their code is available for -- evaluating primitive (Curry-defined) constraints "import qualified CHR(chr2curry)", "import CHRcompiled", "import qualified "++orgmod,""] ++ map showOpDecl chropdecls ++ [""] ++ map showCurryConstraint constraints where exports = "(module CHRcompiled" ++ concatMap (',':) (map (showCName . snd) chrqnames) ++ ")" chrqnames = map (fst . fst) constraints chropdecls = filter (\ (Op qop _ _) -> qop `elem` chrqnames) opdecls -- show operator declaration showOpDecl :: OpDecl -> String showOpDecl (Op op fixity prec) = unwords [showFixity fixity,show prec,showOp op] where showFixity InfixOp = "infix" showFixity InfixlOp = "infixl" showFixity InfixrOp = "infixr" showOp (_,on) = if isAlpha (head on) then '`':on++"`" else on showCurryConstraint :: ((QName,Int),TypeExpr) -> String showCurryConstraint (((_,cname),carity),ctype) = let cargtypes = argTypes carity ctype in showCName cname ++" :: "++ concatMap (++" -> ") cargtypes ++"Goal "++ showCurryType (resultType carity ctype) ++"\n"++ showCName cname ++ concatMap (\i->" x"++show i) [1..carity] ++ " = Goal " ++ take carity (repeat '(') ++ showCName ("prim_"++cname) ++ concatMap (\i->" $!! x"++show i++")") [1..carity] ++ "\n\n" ++ showCName ("prim_"++cname) ++ " :: " ++ concatMap (++" -> ") cargtypes ++ "Bool\n" ++ showCName ("prim_"++cname) ++ " external\n" where resultType arity tp = if arity==0 then let TCons _ [_,chrtype] = tp in chrtype else let FuncType _ rtype = tp in resultType (arity-1) rtype argTypes arity ftype = if arity==0 then [] else let FuncType atype rtype = ftype in showCurryType atype : argTypes (arity-1) rtype -- generate prim_c2p specification of external operations: constraints2xml :: String -> [(QName,Int)] -> XmlExp constraints2xml prologmod constraints = xml "primitives" (map constraint2xml constraints) where constraint2xml ((_,cname),carity) = XElem "primitive" [("name",showCName ("prim_"++cname)), ("arity",show carity)] [xml "library" [xtxt prologmod], xml "entry" [xtxt (showCName ("prim_"++cname))]] -- compile a single CHR rule: compileRule :: (QName -> TypeExpr) -> [(QName,Int)] -> Rule -> ([(QName,Int)],String) compileRule getftype chrs (Rule _ rhs) = let (_,rchrs,trule) = exp2CHR 100 (firstBranch rhs) in (rchrs, trule ++ ".") where exp2CHR i exp@(Comb FuncCall qf [a1,a2]) | qf == (chrMod,"<=>") = let (j, chrs1,tgoal1) = transGoal i a1 (k,_,tgoal2) = transGoal j a2 in (k, chrs1, sg tgoal1 ++" <=> "++ sg tgoal2) | qf == (chrMod,"==>") = let (j,chrs1,tgoal1) = transGoal i a1 (k,_,tgoal2) = transGoal j a2 in (k, chrs1, sg tgoal1 ++" ==> "++ sg tgoal2) | qf == (chrMod,"\\\\") = let (j,chrs1,tgoal1) = transGoal i a1 (k,chrs2,trule2) = exp2CHR j a2 in (k, chrs1++chrs2, sg tgoal1 ++" \\ "++ trule2) | qf == (chrMod,"|>") = let (j,chrs1,trule1) = exp2CHR i a1 (k,_,tgoal2) = transGoal j a2 in (k, chrs1, trule1 ++" | "++ sg tgoal2) | otherwise = error ("Cannot translate CHR rule: " ++ show exp) where sg = showPlGoals transGoal i exp = case reduceApply exp of Comb FuncCall qf args -> if fst qf == chrMod then transCHRPred i qf args else transUserPred i qf args _ -> error ("Cannot translate CHR literal: " ++ show exp) transCHRPred i (_,cname) args | cname=="/\\" = let (j,chrs1,tgoal1) = transGoal i (args!!0) (k,chrs2,tgoal2) = transGoal j (args!!1) in (k, chrs1++chrs2, tgoal1 ++ tgoal2) | cname=="nonvar" = (i, [], [PlLit "nonvar" [transArg (args!!0)]]) | cname=="ground" = (i, [], [PlLit "ground" [transArg (args!!0)]]) | cname=="true" = (i, [], [PlLit "true" []]) | cname=="fail" = (i, [], [PlLit "fail" []]) | otherwise = maybe (error $ "Illegal CHR constraint: CHR."++cname) (\chr2pl -> (i, [], [chr2pl (map transArg args)])) (lookup cname chrPrims) transUserPred i qf args = let (j,plits,plit) = flattenLiteral i qf args fplit = if qf `elem` map fst chrs then plit else if isCHRType (getftype qf) then let PlLit pn pargs = plit in PlLit "eval" [PlStruct "CHR.chr2curry" [PlStruct pn pargs]] else error ("Operation '"++snd qf++ "' is not a CHR constraint!") in (j, [(qf,length args)], plits ++ [fplit]) -- check whether the type is a type of a CHR constraint isCHRType :: TypeExpr -> Bool isCHRType texp = case texp of FuncType _ rt -> isCHRType rt TCons qtc _ -> qtc == (chrMod,"Goal") _ -> False -- get the first branch of a function definition firstBranch :: Expr -> Expr firstBranch exp = case exp of Case _ _ (Branch _ bexp : brs) -> if null brs then firstBranch bexp else error ("CHR rule with more than one branch: "++show exp) Free _ fexp -> firstBranch fexp _ -> exp -- reduce h.o. applications to a known function: reduceApply :: Expr -> Expr reduceApply exp = case exp of Comb FuncCall ("Prelude","apply") [a1,a2] -> let ra1 = reduceApply a1 in case ra1 of Comb FuncCall qf fargs -> Comb FuncCall qf (fargs++[a2]) _ -> Comb FuncCall ("Prelude","apply") [ra1,a2] _ -> exp -- Translation table for primitive CHR constraints: chrPrims :: [(String,[PlTerm] -> PlGoal)] chrPrims = [(".=.", \args -> PlLit "sunif" args), ("./=.",\args -> PlLit "sunif" [PlStruct "Prelude.==" args, pfalse]), (".>=.",\args -> PlLit "sunif" [PlStruct "Prelude.>=" args, ptrue]), (".<=.",\args -> PlLit "sunif" [PlStruct "Prelude.<=" args, ptrue]), (".>.", \args -> PlLit "sunif" [PlStruct "Prelude.>" args, ptrue]), (".<.", \args -> PlLit "sunif" [PlStruct "Prelude.<" args, ptrue])] where ptrue = PlAtom "Prelude.True" pfalse = PlAtom "Prelude.False" -- Translate an argument of a CHR constraint: transArg :: Expr -> PlTerm transArg e = case e of Lit (Intc i) -> PlInt i Lit (Floatc f) -> PlFloat f Var i -> PlVar ('X' : show i) Comb FuncCall qf args -> PlStruct (showQName qf) (map transArg args) Comb ConsCall qf args -> PlStruct (transCName qf) (map transArg args) _ -> error ("Not yet translatable argument: "++show e) where transCName qf | qf == ("Prelude","[]") = "[]" | qf == ("Prelude",":") = "." | otherwise = showQName qf -- Flatten a CHR literal: if arguments contain function calls, -- add unification constraints for these arguments. flattenLiteral :: Int -> QName -> [Expr] -> (Int,[PlGoal],PlGoal) flattenLiteral i qf args = let (j,flits,fargs) = flattenArgs i args in (j, flits, PlLit (showQName qf) (map transArg fargs)) -- Replace non-variable arguments by equalities for new variables. -- The first argument and result is a counter for indexing new variables. -- The second result is the Prolog code for new equalities. flattenArgs :: Int -> [Expr] -> (Int,[PlGoal],[Expr]) flattenArgs i [] = (i,[],[]) flattenArgs i (arg:args) = if funcArg arg then let (j,flits,fargs) = flattenArgs (i+1) args in (j, PlLit "sunif" [PlVar ("X"++show i), transArg arg] : flits, Var i:fargs) else let (j,flits,fargs) = flattenArgs i args in (j, flits, arg : fargs) where funcArg e = case e of Lit _ -> False Var _ -> False Comb ConsCall _ cargs -> any funcArg cargs _ -> True -- Show a qualified name: showQName :: QName -> String showQName (mname,fname) = mname++"."++fname -- Show a name in Curry syntax, i.e., encode special characters as alphanum. showCName :: String -> String showCName s | all (\c -> isAlphaNum c || c=='_') s = s | isAlpha (head s) = concatMap (\c -> if isAlphaNum c || c=='_' then [c] else 'X':show (ord c)) s | otherwise = "("++s++")" -- The name of the Curry CHR module: chrMod :: String chrMod = "CHR" ---------------------------------------------------------------------- -- Auxiliaries used in the compiled CHR(Prolog) code. --- Transforms a primitive CHR constraint into a Curry constraint. --- Used in the generated CHR(Prolog) code to evaluated primitive --- constraints. chr2curry :: CHR.Goal dom chr -> Bool chr2curry (CHR.Goal c) = case c of [CHR.PrimCHR pc] -> CHR.evalPrimCHR pc _ -> error "CHRcompiled.chr2curry: unexpected argument!" ---------------------------------------------------------------------- -- Use FlatCurry pretty printer to show a non-top-level type expression. showCurryType :: TypeExpr -> String showCurryType te = '(' : pretty 78 (ppTypeExp defaultOptions te) ++ ")" ---------------------------------------------------------------------- curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/CHRcompiled.curry.pakcs000066400000000000000000000037311305333611600255530ustar00rootroot00000000000000---------------------------------------------------------------------- --- This module defines the structure of CHR goals and some constructors --- to be used in compiled CHR(Curry) rules. --- Furthermore, it defines an operation `solveCHR` to solve --- a CHR goal as a constraint. --- --- This module is imported in compiled CHR(Curry) programs, --- compare library `CHR`. --- --- @author Michael Hanus --- @version February 2015 --- @category general ---------------------------------------------------------------------- module CHRcompiled where import qualified CHR infixr 4 /\ --- A typed CHR goal. --- Since types are not present at run-time in compiled, --- we use a phantom type to parameterize goals over CHR constraints. --- The argument of the goal is the constraint implementing the goal --- with the compiled CHR(Prolog) program. data Goal _ = Goal Bool --- Conjunction of CHR goals. (/\) :: Goal chr -> Goal chr -> Goal chr (/\) (Goal g1) (Goal g2) = Goal (g1 & g2) --- The always satisfiable CHR constraint. true :: Goal _ true = Goal True --- The always failing constraint. fail :: Goal _ fail = Goal failed --- Join a list of CHR goals into a single CHR goal (by conjunction). andCHR :: [Goal chr] -> Goal chr andCHR = foldr (/\) true --- Is a given constraint abstraction satisfied by all elements in a list? allCHR :: (a -> Goal chr) -> [a] -> Goal chr allCHR fc = andCHR . map fc --- Evaluate a given CHR goal and embed this as a constraint in Curry. --- Note: due to limitations of the CHR(Prolog) implementation, --- no warning is issued if residual constraints remain after the evaluation. solveCHR :: Goal chr -> Bool solveCHR (Goal g) | g = warnSuspendedConstraints True --- Primitive operation that issues a warning if there are some --- suspended constraints in the CHR constraint store. --- If the argument is true, then all suspended constraints are shown, --- otherwise only the first one. warnSuspendedConstraints :: Bool -> Bool warnSuspendedConstraints external curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/CHRcompiled.prim_c2p000066400000000000000000000004551305333611600250220ustar00rootroot00000000000000 prim_chr warnSuspendedConstraints curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/CLP/000077500000000000000000000000001305333611600216465ustar00rootroot00000000000000curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/CLP/FD.curry.pakcs000066400000000000000000000313701305333611600243310ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for finite domain constraint solving. --- --- An FD problem is specified as an expression of type `FDConstr` --- using the constraints and expressions offered in this library. --- FD variables are created by the operation `domain`. --- An FD problem is solved by calling `solveFD` with labeling options, --- the FD variables whose values should be included in the output, --- and a constraint. Hence, the typical program structure to solve --- an FD problem is as follows: --- --- main :: [Int] --- main = --- let fdvars = take n (domain u o) --- fdmodel = {description of FD problem} --- in solveFD {options} fdvars fdmodel --- --- where `n` are the number of variables and `[u..o]` is the --- range of their possible values. --- --- @author Michael Hanus --- @version February 2015 --- @category general ------------------------------------------------------------------------------ module CLP.FD ( FDConstr, FDExpr, FDRel(..), Option(..), fd , allDifferent, domain, sum, scalarProduct, count , (*#), (+#), (-#) , (=#), (/=#), (<#), (<=#), (>#), (>=#) , true, (/\), andC, allC , solveFD, solveFDAll, solveFDOne ) where import qualified CLPFD as C import Findall (allValues, someValue) infixl 7 *# infixl 6 +#, -# infix 4 =#, /=#, <#, <=#, >#, >=# infixr 3 /\ ------------------------------------------------------------------------------ --- Operations to construct basic constraints. --- Returns infinite list of FDVars with a given domain. --- @param min - minimum value for all variables in xs --- @param max - maximum value for all variables in xs domain :: Int -> Int -> [FDExpr] domain min max = genFDVars min max where genFDVars :: Int -> Int -> [FDExpr] genFDVars l u = FDVar l u _ : genFDVars l u --- Represent an integer value as an FD expression. fd :: Int -> FDExpr fd v = FDInt v --- Addition of FD expressions. (+#) :: FDExpr -> FDExpr -> FDExpr x +# y = FDBinExp Plus x y --- Subtraction of FD expressions. (-#) :: FDExpr -> FDExpr -> FDExpr x -# y = FDBinExp Minus x y --- Multiplication of FD expressions. (*#) :: FDExpr -> FDExpr -> FDExpr x *# y = FDBinExp Times x y --- Equality of FD expressions. (=#) :: FDExpr -> FDExpr -> FDConstr x =# y = FDRelCon Equ x y --- Disequality of FD expressions. (/=#) :: FDExpr -> FDExpr -> FDConstr x /=# y = FDRelCon Neq x y --- "Less than" constraint on FD expressions. (<#) :: FDExpr -> FDExpr -> FDConstr x <# y = FDRelCon Lt x y --- "Less than or equal" constraint on FD expressions. (<=#) :: FDExpr -> FDExpr -> FDConstr x <=# y = FDRelCon Leq x y --- "Greater than" constraint on FD expressions. (>#) :: FDExpr -> FDExpr -> FDConstr x ># y = FDRelCon Gt x y --- "Greater than or equal" constraint on FD expressions. (>=#) :: FDExpr -> FDExpr -> FDConstr x >=# y = FDRelCon Geq x y --- The always satisfied FD constraint. true :: FDConstr true = FDTrue --- Conjunction of FD constraints. (/\) :: FDConstr -> FDConstr -> FDConstr c1 /\ c2 = FDAnd c1 c2 --- Conjunction of a list of FD constraints. andC :: [FDConstr] -> FDConstr andC = foldr (/\) true --- Maps a constraint abstraction to a list of FD constraints and joins them. allC :: (a -> FDConstr) -> [a] -> FDConstr allC c = andC . map c --------------------------------------------------------------------------- -- Complex constraints. --- Possible relations between FD values. --- @cons Equ - Equal --- @cons Neq - Not equal --- @cons Lt - Less than --- @cons Leq - Less than or equal --- @cons Gt - Greater than --- @cons Geq - Greater than or equal data FDRel = Equ | Neq | Lt | Leq | Gt | Geq --- "All different" constraint on FD variables. --- @param xs - list of FD variables --- @return satisfied if the FD variables in the argument list xs --- have pairwise different values. allDifferent :: [FDExpr] -> FDConstr allDifferent vs = FDAllDiff vs --- Relates the sum of FD variables with some integer of FD variable. sum :: [FDExpr] -> FDRel -> FDExpr -> FDConstr sum vs rel v = FDSum vs rel v --- `(scalarProduct cs vs relop v)` is satisfied if `(sum (cs*vs) relop v)` --- is satisfied. --- The first argument must be a list of integers. The other arguments are as --- in 'sum'. scalarProduct :: [FDExpr] -> [FDExpr] -> FDRel -> FDExpr -> FDConstr scalarProduct cs vs rel v = FDScalar cs vs rel v --- `(count v vs relop c)` is satisfied if `(n relop c)`, --- where `n` is the number of elements in the --- list of FD variables `vs` that are equal to `v`, is satisfied. --- The first argument must be an integer. The other arguments are as --- in 'sum'. count :: FDExpr -> [FDExpr] -> FDRel -> FDExpr -> FDConstr count v vs rel c = FDCount v vs rel c --------------------------------------------------------------------------- --- This datatype defines options to control the instantiation of --- FD variables in the solver ('solveFD'). --- --- @cons LeftMost - The leftmost variable is selected for instantiation (default) --- @cons FirstFail - The leftmost variable with the smallest domain is selected --- (also known as first-fail principle) --- @cons FirstFailConstrained - The leftmost variable with the smallest domain --- and the most constraints on it is selected. --- @cons Min - The leftmost variable with the smalled lower bound is selected. --- @cons Max - The leftmost variable with the greatest upper bound is selected. --- @cons Step - Make a binary choice between `x=#b` and --- `x/=#b` for the selected variable --- `x` where `b` is the lower or --- upper bound of `x` (default). --- @cons Enum - Make a multiple choice for the selected variable for all the values --- in its domain. --- @cons Bisect - Make a binary choice between `x<=#m` and --- `x>#m` for the selected variable --- `x` where `m` is the midpoint --- of the domain `x` --- (also known as domain splitting). --- @cons Up - The domain is explored for instantiation in ascending order (default). --- @cons Down - The domain is explored for instantiation in descending order. --- @cons All - Enumerate all solutions by backtracking (default). --- @cons Minimize v - Find a solution that minimizes the domain variable v --- (using a branch-and-bound algorithm). --- @cons Maximize v - Find a solution that maximizes the domain variable v --- (using a branch-and-bound algorithm). --- @cons Assumptions x - The variable x is unified with the number of choices --- made by the selected enumeration strategy when --- a solution is found. --- @cons RandomVariable x - Select a random variable for instantiation --- where `x` is a seed value for the random numbers --- (only supported by SWI-Prolog). --- @cons RandomValue x - Label variables with random integer values --- where `x` is a seed value for the random numbers --- (only supported by SWI-Prolog). data Option = LeftMost | FirstFail | FirstFailConstrained | Min | Max | Step | Enum | Bisect | Up | Down | All | Minimize Int | Maximize Int | Assumptions Int | RandomVariable Int | RandomValue Int ------------------------------------------------------------------------ -- Abstract types to represent FD constraints as data. -- Abstract type for FD expressions: data FDExpr = FDVar Int Int Int -- variable with domain and value | FDInt Int | FDBinExp FDOp FDExpr FDExpr data FDOp = Plus | Minus | Times -- Abstract type for FD constraints: data FDConstr = FDTrue | FDRelCon FDRel FDExpr FDExpr | FDAnd FDConstr FDConstr | FDAllDiff [FDExpr] | FDSum [FDExpr] FDRel FDExpr | FDScalar [FDExpr] [FDExpr] FDRel FDExpr | FDCount FDExpr [FDExpr] FDRel FDExpr ------------------------------------------------------------------------ -- The solver is implemented by a transformation into the old CLPFD solver: --- Computes (non-deterministically) a solution for the FD variables (second --- argument) w.r.t. constraint (third argument), where --- the values in the solution correspond to the list of FD variables. --- The first argument contains options to control the labeling/instantiation --- of FD variables. solveFD :: [Option] -> [FDExpr] -> FDConstr -> [Int] solveFD options cvars constr = let domconstr = all (\ (FDVar l u v) -> C.domain [v] l u) (allFDVars constr) tconstr = trC constr allvars = map getFDVal cvars labelvars = C.labeling (map trO options) allvars in (domconstr & tconstr & labelvars) &> allvars --- Computes all solutions for the FD variables (second --- argument) w.r.t. constraint (third argument), where --- the values in each solution correspond to the list of FD variables. --- The first argument contains options to control the labeling/instantiation --- of FD variables. solveFDAll :: [Option] -> [FDExpr] -> FDConstr -> [[Int]] solveFDAll options cvars constr = allValues (solveFD options cvars constr) --- Computes a single solution for the FD variables (second --- argument) w.r.t. constraint (third argument), where --- the values in the solution correspond to the list of FD variables. --- The first argument contains options to control the labeling/instantiation --- of FD variables. solveFDOne :: [Option] -> [FDExpr] -> FDConstr -> [Int] solveFDOne options cvars constr = someValue (solveFD options cvars constr) -- get value (possibly an unbound variable) of an FD expression: getFDVal :: FDExpr -> Int getFDVal var = case var of FDVar _ _ v -> v FDInt i -> i FDBinExp fdop fde1 fde2 -> (arithOp fdop) (valOf fde1) (valOf fde2) where valOf e = case e of FDInt i -> i FDBinExp op e1 e2 -> (arithOp op) (valOf e1) (valOf e2) _ -> error $ "FD variable or value expected but FD expression found:\n"++ show e arithOp Plus = (+) arithOp Minus = (-) arithOp Times = (*) -- compute (multi-set) of all variables occurring in a constraint: allFDVars :: FDConstr -> [FDExpr] allFDVars FDTrue = [] allFDVars (FDRelCon _ fde1 fde2) = allEFDVars fde1 ++ allEFDVars fde2 allFDVars (FDAnd c1 c2) = allFDVars c1 ++ allFDVars c2 allFDVars (FDAllDiff fdvars) = filterVars fdvars allFDVars (FDSum fdvars _ fdv) = filterVars (fdvars ++ [fdv]) allFDVars (FDScalar cs fdvars _ fdv) = filterVars (cs ++ fdvars ++ [fdv]) allFDVars (FDCount fdv fdvars _ c) = filterVars (fdvars ++ [fdv,c]) -- filter variables in a list of FD expressions filterVars :: [FDExpr] -> [FDExpr] filterVars = concatMap allEFDVars allEFDVars :: FDExpr -> [FDExpr] allEFDVars e = case e of FDVar _ _ _ -> [e] FDInt _ -> [] FDBinExp _ e1 e2 -> allEFDVars e1 ++ allEFDVars e2 trC :: FDConstr -> Bool trC FDTrue = True trC (FDRelCon rel fde1 fde2) = (trFDRel rel) (trE fde1) (trE fde2) trC (FDAnd fde1 fde2) = trC fde1 & trC fde2 trC (FDAllDiff fdvars) = C.allDifferent (map getFDVal fdvars) trC (FDSum fdvars relop fdv) = C.sum (map getFDVal fdvars) (trFDRel relop) --(\e1 e2 -> trC (rel (FDInt e1) (FDInt e2))) (getFDVal fdv) trC (FDScalar cs fdvars relop fdv) = C.scalarProduct (map getFDVal cs) (map getFDVal fdvars) (trFDRel relop) (getFDVal fdv) trC (FDCount fdv fdvars relop c) = C.count (getFDVal fdv) (map getFDVal fdvars) (trFDRel relop) (getFDVal c) trE :: FDExpr -> Int trE (FDVar _ _ v) = v trE (FDInt i) = i trE (FDBinExp rel fde1 fde2) = (trFDOp rel) (trE fde1) (trE fde2) trFDRel :: FDRel -> Int -> Int -> Bool trFDRel Equ = (C.=#) trFDRel Neq = (C./=#) trFDRel Lt = (C.<#) trFDRel Leq = (C.<=#) trFDRel Gt = (C.>#) trFDRel Geq = (C.>=#) trFDOp :: FDOp -> Int -> Int -> Int trFDOp Plus = (C.+#) trFDOp Minus = (C.-#) trFDOp Times = (C.*#) trO :: Option -> C.LabelingOption trO option = case option of LeftMost -> C.LeftMost FirstFail -> C.FirstFail FirstFailConstrained -> C.FirstFailConstrained Min -> C.Min Max -> C.Max Step -> C.Step Step -> C.Min Enum -> C.Enum Bisect -> C.Bisect Up -> C.Up Down -> C.Down All -> C.All Minimize n -> C.Minimize n Maximize n -> C.Maximize n Assumptions n -> C.Assumptions n RandomVariable n -> C.RandomVariable n RandomValue n -> C.RandomValue n _ -> error $ "Unknown option: " ++ show option ------------------------------------------------------------------------ curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/CLPB.curry.pakcs000066400000000000000000000065661305333611600241530ustar00rootroot00000000000000--- This library provides a Boolean Constraint Solver based on BDDs. --- --- @author Sebastian Fischer --- @version May 2006 --- @category general module CLPB ( Boolean, true, false, neg, (.&&), (.||), (./=), (.==), (.<=), (.>=), (.<), (.>), count, exists, satisfied, check, bound, simplify, evaluate ) where infixr 3 .&& infixr 2 .|| infix 1 ./=, .== data Boolean = B Int -- abstract --- The always satisfied constraint true :: Boolean true = B 1 --- The never satisfied constraint false :: Boolean false = B 0 --- Result is true iff argument is false. neg :: Boolean -> Boolean neg (B x) = B (prim_neg $! x) prim_neg :: Int -> Int prim_neg external --- Result is true iff both arguments are true. (.&&) :: Boolean -> Boolean -> Boolean (B x) .&& (B y) = B ((prim_and $!y) $! x) prim_and :: Int -> Int -> Int prim_and external --- Result is true iff at least one argument is true. (.||) :: Boolean -> Boolean -> Boolean (B x) .|| (B y) = B ((prim_or $!y) $! x) prim_or :: Int -> Int -> Int prim_or external --- Result is true iff exactly one argument is true. (./=) :: Boolean -> Boolean -> Boolean (B x) ./= (B y) = B ((prim_xor $!y) $! x) prim_xor :: Int -> Int -> Int prim_xor external --- Result is true iff both arguments are equal. (.==) :: Boolean -> Boolean -> Boolean x .== y = neg x ./= y --- Result is true iff the first argument implies the second. (.<=) :: Boolean -> Boolean -> Boolean x .<= y = neg x .|| y --- Result is true iff the second argument implies the first. (.>=) :: Boolean -> Boolean -> Boolean x .>= y = y .<= x --- Result is true iff the first argument is false and the second is true. (.<) :: Boolean -> Boolean -> Boolean x .< y = neg x .&& y --- Result is true iff the first argument is true and the second is false. (.>) :: Boolean -> Boolean -> Boolean x .> y = y .< x --- Result is true iff the count of valid constraints in the first list --- is an element of the second list. count :: [Boolean] -> [Int] -> Boolean count bs ns = B ((card $!! map ensureNotFree (ensureSpine ns)) $!! map int (ensureSpine bs)) card :: [Int] -> [Int] -> Int card external --- Result is true, if the first argument is a variable which can be --- instantiated such that the second argument is true. exists :: Boolean -> Boolean -> Boolean exists (B v) (B b) = B ((prim_exists $!! v) $!! b) prim_exists :: Int -> Int -> Int prim_exists external --- Checks the consistency of the constraint with regard to the accumulated --- constraints, and, if the check succeeds, tells the constraint. satisfied :: Boolean -> Bool satisfied (B b) = sat $!! b sat :: Int -> Bool sat external --- Asks whether the argument (or its negation) is now entailed by the --- accumulated constraints. Fails if it is not. check :: Boolean -> Bool check (B b) = (prim_check $!! b) == 1 prim_check :: Int -> Int prim_check external --- Instantiates given variables with regard to the accumulated constraints. bound :: [Boolean] -> Bool bound bs = labeling $!! map int (ensureSpine bs) labeling :: [Int] -> Bool labeling external --- Simplifies the argument with regard to the accumulated constraints. simplify :: Boolean -> Boolean simplify b | satisfied (a .== b) = a where a free --- Evaluates the argument with regard to the accumulated constraints. evaluate :: Boolean -> Bool evaluate x | bound [y] = int y == 1 where y = simplify x -- private int :: Boolean -> Int int (B x) = x curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/CLPB.prim_c2p000066400000000000000000000021731305333611600234100ustar00rootroot00000000000000 prim_clpb clpb_neg prim_clpb clpb_and prim_clpb clpb_or prim_clpb clpb_xor prim_clpb clpb_card prim_clpb clpb_exists prim_clpb clpb_sat prim_clpb clpb_check prim_clpb clpb_labeling curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/CLPFD.curry.pakcs000066400000000000000000000270601305333611600242530ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for finite domain constraint solving. ---

--- The general structure of a specification of an FD problem is as follows: --- --- domain_constraint & fd_constraint & labeling --- --- where: --- --- domain_constraint --- specifies the possible range of the FD variables (see constraint domain) --- --- fd_constraint --- specifies the constraint to be satisfied by a valid solution --- (see constraints #+, #-, allDifferent, etc below) --- --- labeling --- is a labeling function to search for a concrete solution. --- --- Note: This library is based on the corresponding library of Sicstus-Prolog --- but does not implement the complete functionality of the --- Sicstus-Prolog library. --- However, using the PAKCS interface for external functions, it is relatively --- easy to provide the complete functionality. --- --- @author Michael Hanus --- @version June 2012 --- @category general ------------------------------------------------------------------------------ module CLPFD(domain, (+#), (-#), (*#), (=#), (/=#), (<#), (<=#), (>#), (>=#), Constraint, (#=#), (#/=#), (#<#), (#<=#), (#>#), (#>=#), neg, (#/\#), (#\/#), (#=>#), (#<=>#), solve, sum, scalarProduct, allDifferent, all_different, count, indomain, labeling, LabelingOption(..)) where -- The operator declarations are similar to the standard arithmetic -- and relational operators. infixl 7 *# infixl 6 +#, -# infix 4 =#, /=#, <#, <=#, >#, >=# infix 4 #=#, #/=#, #<#, #<=#, #>#, #>=# infixr 3 #/\# infixr 2 #\/# infixr 1 #=>#, #<=># --- Constraint to specify the domain of all finite domain variables. --- @param xs - list of finite domain variables --- @param min - minimum value for all variables in xs --- @param max - maximum value for all variables in xs domain :: [Int] -> Int -> Int -> Bool domain vs l u = ((prim_domain $!! (ensureSpine vs)) $# l) $# u prim_domain :: [Int] -> Int -> Int -> Bool prim_domain external --- Addition of FD variables. (+#) :: Int -> Int -> Int x +# y = (prim_FD_plus $! y) $! x prim_FD_plus :: Int -> Int -> Int prim_FD_plus external --- Subtraction of FD variables. (-#) :: Int -> Int -> Int x -# y = (prim_FD_minus $! y) $! x prim_FD_minus :: Int -> Int -> Int prim_FD_minus external --- Multiplication of FD variables. (*#) :: Int -> Int -> Int x *# y = (prim_FD_times $! y) $! x prim_FD_times :: Int -> Int -> Int prim_FD_times external --- Equality of FD variables. (=#) :: Int -> Int -> Bool x =# y = (prim_FD_equal $! y) $! x prim_FD_equal :: Int -> Int -> Bool prim_FD_equal external --- Disequality of FD variables. (/=#) :: Int -> Int -> Bool x /=# y = (prim_FD_notequal $! y) $! x prim_FD_notequal :: Int -> Int -> Bool prim_FD_notequal external --- "Less than" constraint on FD variables. (<#) :: Int -> Int -> Bool x <# y = (prim_FD_le $! y) $! x prim_FD_le :: Int -> Int -> Bool prim_FD_le external --- "Less than or equal" constraint on FD variables. (<=#) :: Int -> Int -> Bool x <=# y = (prim_FD_leq $! y) $! x prim_FD_leq :: Int -> Int -> Bool prim_FD_leq external --- "Greater than" constraint on FD variables. (>#) :: Int -> Int -> Bool x ># y = (prim_FD_ge $! y) $! x prim_FD_ge :: Int -> Int -> Bool prim_FD_ge external --- "Greater than or equal" constraint on FD variables. (>=#) :: Int -> Int -> Bool x >=# y = (prim_FD_geq $! y) $! x prim_FD_geq :: Int -> Int -> Bool prim_FD_geq external --------------------------------------------------------------------------- -- Reifyable constraints. --- A datatype to represent reifyable constraints. data Constraint = FDEqual Int Int | FDNotEqual Int Int | FDGreater Int Int | FDGreaterOrEqual Int Int | FDLess Int Int | FDLessOrEqual Int Int | FDNeg Constraint | FDAnd Constraint Constraint | FDOr Constraint Constraint | FDImply Constraint Constraint | FDEquiv Constraint Constraint --- Reifyable equality constraint on FD variables. (#=#) :: Int -> Int -> Constraint x #=# y = FDEqual x y --- Reifyable inequality constraint on FD variables. (#/=#) :: Int -> Int -> Constraint x #/=# y = FDNotEqual x y --- Reifyable "less than" constraint on FD variables. (#<#) :: Int -> Int -> Constraint x #<# y = FDLess x y --- Reifyable "less than or equal" constraint on FD variables. (#<=#) :: Int -> Int -> Constraint x #<=# y = FDLessOrEqual x y --- Reifyable "greater than" constraint on FD variables. (#>#) :: Int -> Int -> Constraint x #># y = FDGreater x y --- Reifyable "greater than or equal" constraint on FD variables. (#>=#) :: Int -> Int -> Constraint x #>=# y = FDGreaterOrEqual x y --- The resulting constraint is satisfied if both argument constraints --- are satisfied. neg :: Constraint -> Constraint neg x = FDNeg x --- The resulting constraint is satisfied if both argument constraints --- are satisfied. (#/\#) :: Constraint -> Constraint -> Constraint x #/\# y = FDAnd x y --- The resulting constraint is satisfied if both argument constraints --- are satisfied. (#\/#) :: Constraint -> Constraint -> Constraint x #\/# y = FDOr x y --- The resulting constraint is satisfied if the first argument constraint --- do not hold or both argument constraints are satisfied. (#=>#) :: Constraint -> Constraint -> Constraint x #=># y = FDImply x y --- The resulting constraint is satisfied if both argument constraint --- are either satisfied and do not hold. (#<=>#) :: Constraint -> Constraint -> Constraint x #<=># y = FDEquiv x y --- Solves a reified constraint. solve :: Constraint -> Bool solve c = prim_solve_reify $!! c prim_solve_reify :: Constraint -> Bool prim_solve_reify external --------------------------------------------------------------------------- -- Complex constraints. --- Relates the sum of FD variables with some integer of FD variable. sum :: [Int] -> (Int -> Int -> Bool) -> Int -> Bool sum vs rel v = seq (normalForm (ensureSpine vs)) (seq (ensureNotFree rel) (seq v (prim_sum vs rel v))) prim_sum :: [Int] -> (Int -> Int -> Bool) -> Int -> Bool prim_sum external --- (scalarProduct cs vs relop v) is satisfied if ((cs*vs) relop v) is satisfied. --- The first argument must be a list of integers. The other arguments are as --- in sum. scalarProduct :: [Int] -> [Int] -> (Int -> Int -> Bool) -> Int -> Bool scalarProduct cs vs rel v = seq (groundNormalForm cs) (seq (normalForm (ensureSpine vs)) (seq (ensureNotFree rel) (seq v (prim_scalarProduct cs vs rel v)))) prim_scalarProduct :: [Int] -> [Int] -> (Int -> Int -> Bool) -> Int -> Bool prim_scalarProduct external --- (count v vs relop c) is satisfied if (n relop c), where n is the number of --- elements in the list of FD variables vs that are equal to v, is satisfied. --- The first argument must be an integer. The other arguments are as --- in sum. count :: Int -> [Int] -> (Int -> Int -> Bool) -> Int -> Bool count v vs rel c = seq (ensureNotFree v) (seq (normalForm (ensureSpine vs)) (seq (ensureNotFree rel) (seq c (prim_count v vs rel c)))) prim_count :: Int -> [Int] -> (Int -> Int -> Bool) -> Int -> Bool prim_count external --- "All different" constraint on FD variables. --- @param xs - list of FD variables --- @return satisfied if the FD variables in the argument list xs --- have pairwise different values. allDifferent :: [Int] -> Bool allDifferent vs = seq (normalForm (ensureSpine vs)) (prim_allDifferent vs) --- For backward compatibility. Use allDifferent. all_different :: [Int] -> Bool all_different = allDifferent prim_allDifferent :: [Int] -> Bool prim_allDifferent external --- Instantiate a single FD variable to its values in the specified domain. indomain :: Int -> Bool indomain x = seq x (prim_indomain x) prim_indomain :: Int -> Bool prim_indomain external --------------------------------------------------------------------------- -- Labeling. --- Instantiate FD variables to their values in the specified domain. --- @param options - list of option to control the instantiation of FD variables --- @param xs - list of FD variables that are non-deterministically --- instantiated to their possible values. labeling :: [LabelingOption] -> [Int] -> Bool labeling options vs = seq (normalForm (map ensureNotFree (ensureSpine options))) (seq (normalForm (ensureSpine vs)) (prim_labeling options vs)) prim_labeling :: [LabelingOption] -> [Int] -> Bool prim_labeling external --- This datatype contains all options to control the instantiated of FD variables --- with the enumeration constraint labeling. --- @cons LeftMost - The leftmost variable is selected for instantiation (default) --- @cons FirstFail - The leftmost variable with the smallest domain is selected --- (also known as first-fail principle) --- @cons FirstFailConstrained - The leftmost variable with the smallest domain --- and the most constraints on it is selected. --- @cons Min - The leftmost variable with the smalled lower bound is selected. --- @cons Max - The leftmost variable with the greatest upper bound is selected. --- @cons Step - Make a binary choice between x=#b and --- x/=#b for the selected variable --- x where b is the lower or --- upper bound of x (default). --- @cons Enum - Make a multiple choice for the selected variable for all the values --- in its domain. --- @cons Bisect - Make a binary choice between x<=#m and --- x>#m for the selected variable --- x where m is the midpoint --- of the domain x --- (also known as domain splitting). --- @cons Up - The domain is explored for instantiation in ascending order (default). --- @cons Down - The domain is explored for instantiation in descending order. --- @cons All - Enumerate all solutions by backtracking (default). --- @cons Minimize v - Find a solution that minimizes the domain variable v --- (using a branch-and-bound algorithm). --- @cons Maximize v - Find a solution that maximizes the domain variable v --- (using a branch-and-bound algorithm). --- @cons Assumptions x - The variable x is unified with the number of choices --- made by the selected enumeration strategy when a solution --- is found. --- @cons RandomVariable x - Select a random variable for instantiation --- where `x` is a seed value for the random numbers --- (only supported by SWI-Prolog). --- @cons RandomValue x - Label variables with random integer values --- where `x` is a seed value for the random numbers --- (only supported by SWI-Prolog). data LabelingOption = LeftMost | FirstFail | FirstFailConstrained | Min | Max | Step | Enum | Bisect | Up | Down | All | Minimize Int | Maximize Int | Assumptions Int | RandomVariable Int | RandomValue Int -- end of library CLPFD curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/CLPFD.prim_c2p000066400000000000000000000042571305333611600235250ustar00rootroot00000000000000 prim_clpfd prim_FD_plus prim_clpfd prim_FD_minus prim_clpfd prim_FD_times prim_clpfd prim_FD_equal prim_clpfd prim_FD_notequal prim_clpfd prim_FD_le prim_clpfd prim_FD_leq prim_clpfd prim_FD_ge prim_clpfd prim_FD_solve_reify prim_clpfd prim_FD_geq prim_clpfd prim_FD_domain prim_clpfd prim_FD_sum prim_clpfd prim_FD_scalar_product prim_clpfd prim_FD_count prim_clpfd prim_FD_all_different prim_clpfd prim_FD_indomain prim_clpfd prim_FD_labeling curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/CLPR.curry.pakcs000066400000000000000000000066711305333611600241700ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for constraint programming with arithmetic constraints over reals. --- --- @category general ------------------------------------------------------------------------------ module CLPR((+.),(-.),(*.),(/.),(<.),(>.),(<=.),(>=.),i2f, minimumFor,minimize,maximumFor,maximize) where -- The operator declarations are similar to the standard arithmetic operators. infixl 7 *., /. infixl 6 +., -. infix 4 <., >., <=., >=. --- Addition on floats in arithmetic constraints. (+.) :: Float -> Float -> Float x +. y = (prim_CLPR_plus $! y) $! x prim_CLPR_plus :: Float -> Float -> Float prim_CLPR_plus external --- Subtraction on floats in arithmetic constraints. (-.) :: Float -> Float -> Float x -. y = (prim_CLPR_minus $! y) $! x prim_CLPR_minus :: Float -> Float -> Float prim_CLPR_minus external --- Multiplication on floats in arithmetic constraints. (*.) :: Float -> Float -> Float x *. y = (prim_CLPR_times $! y) $! x prim_CLPR_times :: Float -> Float -> Float prim_CLPR_times external --- Division on floats in arithmetic constraints. (/.) :: Float -> Float -> Float x /. y = (prim_CLPR_div $! y) $! x prim_CLPR_div :: Float -> Float -> Float prim_CLPR_div external --- "Less than" constraint on floats. (<.) :: Float -> Float -> Bool x <. y = (prim_CLPR_le $! y) $! x prim_CLPR_le :: Float -> Float -> Bool prim_CLPR_le external --- "Greater than" constraint on floats. (>.) :: Float -> Float -> Bool x >. y = (prim_CLPR_ge $! y) $! x prim_CLPR_ge :: Float -> Float -> Bool prim_CLPR_ge external --- "Less than or equal" constraint on floats. (<=.) :: Float -> Float -> Bool x <=. y = (prim_CLPR_leq $! y) $! x prim_CLPR_leq :: Float -> Float -> Bool prim_CLPR_leq external --- "Greater than or equal" constraint on floats. (>=.) :: Float -> Float -> Bool x >=. y = (prim_CLPR_geq $! y) $! x prim_CLPR_geq :: Float -> Float -> Bool prim_CLPR_geq external --- Conversion function from integers to floats. --- Rigid in the first argument, i.e., suspends until the first argument --- is ground. i2f :: Int -> Float i2f x = prim_CLPR_i2f $# x prim_CLPR_i2f :: Int -> Float prim_CLPR_i2f external --- Computes the minimum with respect to a given constraint. --- (minimumFor g f) evaluates to x if (g x) is satisfied and --- (f x) is minimal. The evaluation fails if such a minimal value --- does not exist. The evaluation suspends if it contains --- unbound non-local variables. minimumFor :: (a -> Bool) -> (a -> Float) -> a minimumFor external --- Minimization constraint. --- (minimize g f x) is satisfied if (g x) is satisfied and --- (f x) is minimal. The evaluation suspends if it contains --- unbound non-local variables. minimize :: (a -> Bool) -> (a -> Float) -> a -> Bool minimize g f x = minimumFor g f =:= x --- Computes the maximum with respect to a given constraint. --- (maximumFor g f) evaluates to x if (g x) is satisfied and --- (f x) is maximal. The evaluation fails if such a maximal value --- does not exist. The evaluation suspends if it contains --- unbound non-local variables. maximumFor :: (a -> Bool) -> (a -> Float) -> a maximumFor external --- Maximization constraint. --- (maximize g f x) is satisfied if (g x) is satisfied and --- (f x) is maximal. The evaluation suspends if it contains --- unbound non-local variables. maximize :: (a -> Bool) -> (a -> Float) -> a -> Bool maximize g f x = maximumFor g f =:= x -- end of CLPR curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/CLPR.prim_c2p000066400000000000000000000027161305333611600234330ustar00rootroot00000000000000 prim_clpr prim_CLPR_plus prim_clpr prim_CLPR_minus prim_clpr prim_CLPR_times prim_clpr prim_CLPR_div prim_clpr prim_CLPR_le prim_clpr prim_CLPR_ge prim_clpr prim_CLPR_leq prim_clpr prim_CLPR_geq prim_clpr prim_CLPR_i2f prim_clpr prim_minimumFor[raw] prim_clpr prim_maximumFor[raw] curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/CPNS.curry000066400000000000000000000262501305333611600230660ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Implementation of a Curry Port Name Server based on raw sockets. --- It is used to implement the library Ports for distributed programming --- with ports. --- --- @author Michael Hanus --- @version February 2017 --- @category web ------------------------------------------------------------------------------ module CPNS(registerPort,getPortInfo,unregisterPort, cpnsStart,cpnsStop,cpnsShow,cpnsAlive,main) where import Char import Distribution(installDir) import FilePath(()) import IO import List(delete,intersperse) import Profile import ReadShowTerm import Socket import System import Time -- If we connect to a port with symbolic name pn, we first connect -- to the CPNS of the host named by pn to get the physical socket -- number of this port. In order to connect to CPNS from any -- machine in the world, the CPNS demon always listens at the following -- port: -- (Note that this must be identical for all machines running -- Distributed Curry! If this port is occupied by another process -- on a host, you cannot run Distributed Curry on it.) cpnsSocket = 8767 -- standard port number of CPNS demon -- The time out before considering the server as unreachable: cpnsTimeOut = 3000 --- Type of messages to be processed by the Curry Port Name Server. --- --- @cons Register name pid sn pn ack --- - assign the values pid, sn, and pn to name --- (pid is the process number of the registered process --- (should be 0 if it is unknown); the server returns True --- if registration had no problems, otherwise False) --- @cons GetRegister name - request for a registered port name; --- the server returns the values (sn,pn) that are assigned to the --- port name --- @cons Unregister name - request to remove a registered port name --- @cons ShowRegistry - show the current port registrations --- @cons Ping - ping the CPNS demon for liveness check --- @cons Terminate - terminate the CPNS demon data CPNSMessage = Terminate | Ping | Register String Int Int Int | GetRegister String | Unregister String | ShowRegistry -- The lock file to coordinate the startup of the CPNS demon: cpnsStartupLockfile = "/tmp/CurryPNSD.lock" --- Starts the "Curry Port Name Server" (CPNS) running on the local machine. --- The CPNS is responsible to resolve symbolic names for ports --- into physical socket numbers so that a port can be reached --- under its symbolic name from any machine in the world. cpnsStart :: IO () cpnsStart = catch startup (\_ -> putStrLn "FAILURE occurred during startup!" >> deleteStartupLockfile >> return Nothing) >>= maybe done (cpnsServer []) where deleteStartupLockfile = do putStrLn $ "Removing startup lock file \""++cpnsStartupLockfile++"\"..." system $ "rm -f "++cpnsStartupLockfile done startup = do putStrLn $ "Starting Curry Port Name Server on port " ++ show cpnsSocket ++ "..." socket <- listenOn cpnsSocket deleteStartupLockfile pid <- getPID putStrLn $ "Curry Port Name Server is ready (PID: "++show pid++")." return (Just socket) --- The main loop of the CPNS demon cpnsServer :: [(String,Int,Int,Int)] -> Socket -> IO () cpnsServer regs socket = do (chost,stream) <- socketAccept socket --putStrLn $ "Connection from "++chost serveRequest chost stream where doIfLocalHost rhost action = do hostname <- getHostname if rhost `elem` ["localhost","localhost.localdomain",hostname] || take 8 rhost == "127.0.0." then action else do putStrLn $ "Illegal request received from host: " ++ rhost cpnsServer regs socket serveRequest rhost h = do msg <- readMsgLine h either (\line -> do putStrLn $ "ERROR: Illegal message:\n" ++ line cpnsServer regs socket ) (\m -> case m of Terminate -> doIfLocalHost rhost $ do hClose h putStrLn "CPNS demon terminated." Ping -> do hPutStrLn h (showQTerm ()) hClose h cpnsServer regs socket Register pname pid sn pn -> doIfLocalHost rhost $ do (ack, newregs) <- tryRegisterPortName regs pname pid sn pn hPutStrLn h (showQTerm ack) hClose h cpnsServer newregs socket GetRegister pname -> do --putStrLn $ "Request for port name: " ++ pname (newregs,pinfo) <- getRegisteredPortName regs pname hPutStrLn h (showQTerm pinfo) hClose h cpnsServer newregs socket Unregister pname -> doIfLocalHost rhost $ do newregs <- unregisterPortName regs pname hClose h cpnsServer newregs socket ShowRegistry -> doIfLocalHost rhost $ do putStrLn "Currently registered port names:" newregs <- showAndCleanRegs regs hFlush stdout hClose h cpnsServer newregs socket ) msg tryRegisterPortName regs name pid sn pn = do let nameregs = filter (\(n,_,_,_)->name==n) regs ack <- if null nameregs then return True else let (_,pid',_,_) = head nameregs in if pid'>0 && pid'/=pid -- we allow registration from the same process then doesProcessExists pid' >>= \pex -> return (not pex) else return True ctime <- getLocalTime putStrLn $ "Register port \""++name++"\": pid "++show pid++ " / socket "++show sn++ " / number "++show pn ++ " at " ++ calendarTimeToString ctime let newregs = (name,pid,sn,pn) : filter (\ (n,_,_,_)->name/=n) regs printMemInfo newregs hFlush stdout return (ack, newregs) -- Delete all registrations for a given port name: unregisterPortName regs name = do ctime <- getLocalTime putStrLn $ "Unregister port \""++name++"\" at "++calendarTimeToString ctime let newregs = filter (\ (n,_,_,_)->name/=n) regs printMemInfo newregs hFlush stdout return newregs -- Get the socket number for a registered port name -- (or (0,0) if not registered). -- In addition, a new registration list is returned where a registration -- is deleted if the corresponding server process does not exist. getRegisteredPortName :: [(String,Int,Int,Int)] -> String -> IO ([(String,Int,Int,Int)],(Int,Int)) getRegisteredPortName regs pname = let nameregs = filter (\(n,_,_,_)->pname==n) regs in if null nameregs then return (regs,(0,0)) else let (_,pid,sn,pn) = head nameregs in if pid>0 then doesProcessExists pid >>= \pex -> if pex then return (regs,(sn,pn)) else --putStrLn ("WARNING: Process "++show pid++" not running!") >> return (delete (head nameregs) regs, (0,0)) else return (regs,(sn,pn)) -- Show all registered ports and return a new registration list -- where a registration is deleted if the corresponding server process -- does not exist. showAndCleanRegs :: [(String,Int,Int,Int)] -> IO [(String,Int,Int,Int)] showAndCleanRegs regs = do newreglist <- mapIO checkAndShow regs return (concat newreglist) where checkAndShow reg@(n,pid,sn,pn) = do pidexist <- doesProcessExists pid if pidexist then do putStrLn $ n++": pid "++show pid++ " / socket "++show sn++" / number "++show pn return [reg] else return [] -- Print status information of current CPNS demon process: printMemInfo :: [(String,Int,Int,Int)] -> IO () printMemInfo regs = do pinfos <- getProcessInfos putStrLn ("NumRegs: " ++ show (length regs) ++ ", " ++ showMemInfo pinfos) -- test whether a process with a given pid is running: doesProcessExists :: Int -> IO Bool doesProcessExists pid = do status <- system("test -z \"`ps -p "++show pid++" | fgrep "++show pid++"`\"") return (status>0) -- Read a line from a stream and check syntactical correctness of message: readMsgLine :: Handle -> IO (Either String a) readMsgLine handle = do line <- hGetLine handle case readsQTerm line of [(msg,rem)] -> return (if all isSpace rem then Right msg else Left line) _ -> return (Left line) -- Perform an action if the CPNS demon at a given host is alive: doIfAlive :: String -> IO a -> IO a doIfAlive host action = do alive <- cpnsAlive cpnsTimeOut host if not alive then error $ "Curry port name server at host \""++host++ "\" is not reachable (timeout after "++show cpnsTimeOut++ " ms)!" else action sendToLocalCPNS :: CPNSMessage -> IO () sendToLocalCPNS msg = doIfAlive "localhost" $ do h <- connectToSocket "localhost" cpnsSocket hPutStrLn h (showQTerm msg) hClose h --- Shows all registered ports at the local CPNS demon (in its logfile). cpnsShow = sendToLocalCPNS ShowRegistry --- Terminates the local CPNS demon cpnsStop = sendToLocalCPNS Terminate --- Gets an answer from a Curry port name server on a host, --- or reports an error. cpnsTryGetAnswer :: String -> CPNSMessage -> IO _ cpnsTryGetAnswer host msg = catch tryGetAnswer connectError where tryGetAnswer = do h <- connectToSocket host cpnsSocket hPutStrLn h (showQTerm msg) hFlush h ready <- hWaitForInput h cpnsTimeOut if ready then do answer <- readMsgLine h hClose h either (\line -> error $ "cpnsTryGetAnswer: Illegal answer: " ++ line) return answer else failed connectError _ = error $ "Curry port name server at host \""++host++ "\" is not reachable!" --- Registers a symbolic port at the local host. registerPort :: String -> Int -> Int -> IO () registerPort pname sn pn = do startCPNSDIfNecessary pid <- getPID ack <- cpnsTryGetAnswer "localhost" (Register pname pid sn pn) if ack then done else putStrLn ("WARNING: Port name '"++pname++"' already registered!") --- Gets the information about a symbolic port at some host. getPortInfo :: String -> String -> IO (Int,Int) getPortInfo pname host = cpnsTryGetAnswer host (GetRegister pname) --- Unregisters a symbolic port at the local host. unregisterPort :: String -> IO () unregisterPort pname = sendToLocalCPNS (Unregister pname) --- Tests whether the CPNS demon at a host is alive. cpnsAlive :: Int -> String -> IO Bool cpnsAlive timeout host = catch tryPingCPNS (\_ -> return False) where tryPingCPNS = do h <- connectToSocket host cpnsSocket hPutStrLn h (showQTerm Ping) hFlush h answer <- hWaitForInput h timeout hClose h return answer --- Starts the CPNS demon at localhost if it is not already running: startCPNSDIfNecessary :: IO () startCPNSDIfNecessary = do system $ installDir "currytools" "cpns" "start" done --- Main function for CPNS demon. Check arguments and execute command. main = do args <- getArgs case args of ["start"] -> cpnsStart ["stop"] -> cpnsStop ["show"] -> cpnsShow _ -> putStrLn $ "ERROR: Illegal arguments: " ++ concat (intersperse " " args) ++ "\n" ++ "Allowed arguments: start|stop|show" {- Test with PAKCS: :fork cpnsStart registerPort "xxx" 42 2 getPortInfo "xxx" "localhost" cpnsStop -} curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/CSV.curry000066400000000000000000000070531305333611600227560ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for reading/writing files in CSV format. --- Files in CSV (comma separated values) format can be imported and exported --- by most spreadsheed and database applications. --- --- @author Michael Hanus --- @version September 2004 --- @category general ------------------------------------------------------------------------------ module CSV(showCSV,readCSV,readCSVWithDelims, writeCSVFile,readCSVFile,readCSVFileWithDelims) where import List(intersperse) --- Writes a list of records (where each record is a list of strings) --- into a file in CSV format. --- @param fname - the name of the result file (with standard suffix ".csv") --- @param rows - the list of rows writeCSVFile :: String -> [[String]] -> IO () writeCSVFile fname rows = writeFile fname (showCSV rows) --- Shows a list of records (where each record is a list of strings) --- as a string in CSV format. showCSV :: [[String]] -> String showCSV rows = concatMap showCSVLine rows --- Shows a list of strings as a line in CSV format. showCSVLine :: [String] -> String showCSVLine row = concat (intersperse "," (map convert row)) ++ "\n" where -- enclose in quotation marks if necessary: convert s = if any (\c->c `elem` ['"',',',';',':','\n']) s then '"' : concatMap (\c->if c=='"' then [c,c] else [c]) s ++ "\"" else s --- Reads a file in CSV format and returns the list of records --- (where each record is a list of strings). --- @param fname - the name of the result file (with standard suffix ".csv") readCSVFile :: String -> IO [[String]] readCSVFile = readCSVFileWithDelims [','] --- Reads a file in CSV format and returns the list of records --- (where each record is a list of strings). --- @param delims - the list of characters considered as delimiters --- @param fname - the name of the result file (with standard suffix ".csv") readCSVFileWithDelims :: [Char] -> String -> IO [[String]] readCSVFileWithDelims delims fname = do contents <- readFile fname return (readCSVWithDelims delims contents) --- Reads a string in CSV format and returns the list of records --- (where each record is a list of strings). --- @param str - the string in CSV format readCSV :: String -> [[String]] readCSV = readCSVWithDelims [','] --- Reads a string in CSV format and returns the list of records --- (where each record is a list of strings). --- @param delims - the list of characters considered as delimiters --- @param str - the string in CSV format readCSVWithDelims :: [Char] -> String -> [[String]] readCSVWithDelims delims str = map (components delims) (lines str) --- Breaks a string in CSV record format into a list of components. components :: [Char] -> String -> [String] components _ [] = [[]] components delims (c:cs) = if c=='"' then breakString cs else let (e,s) = break (`elem` delims) (c:cs) in e : (if null s then [] else components delims (tail s)) where breakString [] = delimError breakString [x] = if x=='"' then [[]] else delimError breakString (x:y:zs) | x=='"' && y=='"' = let (b:bs) = breakString zs in (x:b):bs | x=='"' && y `elem` delims = []:components delims zs | otherwise = let (b:bs) = breakString (y:zs) in (x:b):bs delimError = error "Missing closing delimiter in CSV record!" -- Examples: -- writeCSVFile "tmp.csv" [["Name","Value"],["aa\"bb,cc","1"]] -- readCSVFile "tmp.csv" curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/CategorizedHtmlList.curry000066400000000000000000000071301305333611600262400ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library provides functions to categorize a list of entities --- into a HTML page with an index access (e.g., "A-Z") to these entities. --- --- @category web ------------------------------------------------------------------------------ module CategorizedHtmlList (list2CategorizedHtml, categorizeByItemKey, stringList2ItemList) where import List import HTML import Char --- General categorization of a list of entries. --- --- The item will occur in every category for which the boolean function --- categoryFun yields True. --- @param itemL the list of key-item pairs which are supposed to be --- categorized with respect to key --- @param categoryL list of key-category pairs to which the items can be --- sorted in --- @param categoryFun uses the keys of the items and the keys of the --- categories to distribute the items among the categories. --- @return Html containing inner links between the categories list2CategorizedHtml :: [(a,[HtmlExp])] -> [(b,String)] -> (a -> b -> Bool) -> [HtmlExp] list2CategorizedHtml itemL categoryL categoryFun = categories2LinkList categoryL : map (\ (categoryKey,categoryString) -> anchor (string2urlencoded (show categoryKey)) (h2 [htxt categoryString] : concatMap (\ (_,item)->item++[breakline]) (filter (\ (itemKey,_) -> categoryFun itemKey categoryKey) itemL) ++ [categories2LinkList categoryL]) ) categoryL -- the navigation list categories2LinkList :: [(_,String)] -> HtmlExp categories2LinkList categoryL = par [center (concatMap (\ (categoryKey,categoryString) -> [href ('#':(string2urlencoded (show categoryKey))) [htxt categoryString], nbsp]) categoryL)] --- Categorize a list of entries with respect to the inial keys. --- --- The categories are named as all initial characters of the keys of the items. --- @param itemL the list of key-item pairs which are supposed to be --- categorized with respect to key --- @return Html containing inner links between the categories categorizeByItemKey :: [(String,[HtmlExp])] -> [HtmlExp] categorizeByItemKey itemL = list2CategorizedHtml itemL (map (\c -> (toUpper c,[toUpper c])) (listHeads (map fst itemL))) categorizeStringHead --- Convert a string list into an key-item list --- The strings are used as keys and for the simple text layout. stringList2ItemList :: [String] -> [(String,[HtmlExp])] stringList2ItemList = map (\str -> (str,[htxt str])) -- yields every listHead only once listHeads :: [String] -> [Char] listHeads = nubBy isUpperEqual . foldr (\xs ys -> if xs==[] then ys else head xs:ys) [] -- categoryFun for categorizeByItemKey categorizeStringHead :: String -> Char -> Bool categorizeStringHead [] _ = False categorizeStringHead (c:_) c' = isUpperEqual c c' isUpperEqual c c' = toUpper c == toUpper c' -- just for testing ---------------------------------------- main = return $ form "CatTest" (categorizeByItemKey (stringList2ItemList testList)) testList = ["bbcd", "acde", "ab", "cde", "b", "xt", "gbbcd", "uacde", "Oab", "Qcde", "Tb", "mxt", "mxtr"] -- makecurrycgi -o ~/public_html/cat.cgi CategorizedHtmlList curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Char.curry000066400000000000000000000067441305333611600232060ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library with some useful functions on characters. --- --- @author Michael Hanus, Bjoern Peemoeller --- @version January 2015 --- @category general ------------------------------------------------------------------------------ module Char ( isAscii, isLatin1, isAsciiUpper, isAsciiLower, isControl , isUpper, isLower, isAlpha, isDigit, isAlphaNum , isBinDigit, isOctDigit, isHexDigit, isSpace , toUpper, toLower, digitToInt, intToDigit ) where --- Returns true if the argument is an ASCII character. isAscii :: Char -> Bool isAscii c = c < '\x80' --- Returns true if the argument is an Latin-1 character. isLatin1 :: Char -> Bool isLatin1 c = c < '\xff' --- Returns true if the argument is an ASCII lowercase letter. isAsciiLower :: Char -> Bool isAsciiLower c = c >= 'a' && c <= 'z' --- Returns true if the argument is an ASCII uppercase letter. isAsciiUpper :: Char -> Bool isAsciiUpper c = c >= 'A' && c <= 'Z' --- Returns true if the argument is a control character. isControl :: Char -> Bool isControl c = c < '\x20' || c >= '\x7f' && c <= '\x9f' --- Returns true if the argument is an uppercase letter. isUpper :: Char -> Bool isUpper c = c >= 'A' && c <= 'Z' --- Returns true if the argument is an lowercase letter. isLower :: Char -> Bool isLower c = c >= 'a' && c <= 'z' --- Returns true if the argument is a letter. isAlpha :: Char -> Bool isAlpha c = isUpper c || isLower c --- Returns true if the argument is a decimal digit. isDigit :: Char -> Bool isDigit c = c >= '0' && c <= '9' --- Returns true if the argument is a letter or digit. isAlphaNum :: Char -> Bool isAlphaNum c = isAlpha c || isDigit c --- Returns true if the argument is a binary digit. isBinDigit :: Char -> Bool isBinDigit c = c >= '0' || c <= '1' --- Returns true if the argument is an octal digit. isOctDigit :: Char -> Bool isOctDigit c = c >= '0' && c <= '7' --- Returns true if the argument is a hexadecimal digit. isHexDigit :: Char -> Bool isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f' --- Returns true if the argument is a white space. isSpace :: Char -> Bool isSpace c = c == ' ' || c == '\t' || c == '\n' || c == '\r' || c == '\f' || c == '\v' || c == '\xa0' || ord c `elem` [5760,6158,8192,8239,8287,12288] --- Converts lowercase into uppercase letters. toUpper :: Char -> Char toUpper c | isLower c = chr (ord c - ord 'a' + ord 'A') | otherwise = c --- Converts uppercase into lowercase letters. toLower :: Char -> Char toLower c | isUpper c = chr (ord c - ord 'A' + ord 'a') | otherwise = c --- Converts a (hexadecimal) digit character into an integer. digitToInt :: Char -> Int digitToInt c | isDigit c = ord c - ord '0' | ord c >= ord 'A' && ord c <= ord 'F' = ord c - ord 'A' + 10 | ord c >= ord 'a' && ord c <= ord 'f' = ord c - ord 'a' + 10 | otherwise = error "Char.digitToInt: argument is not a digit" --- Converts an integer into a (hexadecimal) digit character. intToDigit :: Int -> Char intToDigit i | i >= 0 && i <= 9 = chr (ord '0' + i) | i >= 10 && i <= 15 = chr (ord 'A' + i - 10) | otherwise = error "Char.intToDigit: argument not a digit value" curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Combinatorial.curry000066400000000000000000000120431305333611600251010ustar00rootroot00000000000000------------------------------------------------------------------------------ --- A collection of common non-deterministic and/or combinatorial operations. --- Many operations are intended to operate on sets. --- The representation of these sets is not hidden; rather --- sets are represented as lists. --- Ideally these lists contains no duplicate elements and --- the order of their elements cannot be observed. --- In practice, these conditions are not enforced. --- --- @author Sergio Antoy (with extensions by Michael Hanus) --- @version April 2016 --- @category general ------------------------------------------------------------------------------ module Combinatorial(permute, subset, allSubsets, splitSet, sizedSubset, partition) where import List(sum) import SetFunctions import Test.Prop ------------------------------------------------------------------------------ -- Public Operations ------------------------------------------------------------------------------ --- Compute any permutation of a list. --- --- @param xs - The list. --- @return A permutation of the argument. permute :: [a] -> [a] permute [] = [] permute (x:xs) = ndinsert (permute xs) where ndinsert [] = [x] ndinsert (y:ys) = (x:y:ys) ? (y:ndinsert ys) -- Properties: permute1234 = permute [1,2,3,4] ~> [1,3,4,2] -- The length of a permutation is identical to the length of the argument: permLength xs = length (permute xs) <~> length xs -- lengths are equal -- The permutation contains the same elements as the argument: permElems xs = anyOf (permute xs) <~> anyOf xs ------------------------------------------------------------------------------ --- Compute any sublist of a list. --- The sublist contains some of the elements of the list in the same order. --- --- @param xs - The list. --- @return A sublist of the argument. subset :: [a] -> [a] subset [] = [] subset (x:xs) = x:subset xs subset (_:xs) = subset xs -- Properties: subset1234 = subset [1,2,3,4] ~> [1,3] subset123 = subset [1,2,3] <~> ([1,2,3]?[1,2]?[1,3]?[1]?[2,3]?[2]?[3]?[]) subsetElems xs = anyOf (subset xs) <~ anyOf xs ------------------------------------------------------------------------------ --- Compute all the sublists of a list. --- --- @param xs - The list. --- @return All the sublists of the argument. allSubsets :: [a] -> [[a]] allSubsets xs = sortValues (set1 subset xs) -- Properties: allSubsets123 = allSubsets [1,2,3] -=- [[],[1],[1,2],[1,2,3],[1,3],[2],[2,3],[3]] ------------------------------------------------------------------------------ --- Split a list into any two sublists. --- --- @param xs - The list. --- @return A pair consisting of two complementary sublists of the argument. splitSet :: [a] -> ([a],[a]) splitSet [] = ([],[]) splitSet (x:xs) = let (u,v) = splitSet xs in (x:u,v) ? (u,x:v) -- Properties: splitSet1234 = splitSet [1,2,3,4] ~> ([1,3,4],[2]) -- The sum of the length of the two sublists is the length of the argument list: splitSetLengths xs = (\ (xs,ys) -> length xs + length ys) (splitSet xs) <~> length xs -- The two sublists and the argument list have the same elements: splitSetElems xs = (\ (xs,ys) -> anyOf xs ? anyOf ys) (splitSet xs) <~> anyOf xs ------------------------------------------------------------------------------ --- Compute any sublist of fixed length of a list. --- Similar to 'subset', but the length of the result is fixed. --- --- @param c - The length of the output sublist. --- @param xs - The input list. --- @return A sublist of `xs` of length `c`. sizedSubset :: Int -> [a] -> [a] sizedSubset c l = if c == 0 then [] else aux l where aux (x:xs) = x:sizedSubset (c-1) xs ? sizedSubset c xs -- Precondition: sizedSubset'pre c _ = c>=0 -- Properties: sizedSubsetLength c xs = (c>=0 && length xs >= c) ==> length (sizedSubset c xs) <~> c -- No result if the given output length is larger than the length of the input: sizedSubsetLengthTooSmall c xs = (c>=0 && length xs < c) ==> failing (sizedSubset c xs) ------------------------------------------------------------------------------ --- Compute any partition of a list. --- The output is a list of non-empty lists such that their concatenation --- is a permutation of the input list. --- No guarantee is made on the order of the arguments in the output. --- --- @param xs - The input list. --- @return A partition of `xs` represented as a list of lists. partition :: [a] -> [[a]] partition [] = [] partition (x:xs) = insert x (partition xs) where insert e [] = [[e]] insert e (y:ys) = ((e:y):ys) ? (y:insert e ys) -- Properties: partition1234 = partition [1,2,3,4] ~> [[4],[2,3],[1]] partition123 = partition [1,2,3] <~> ([[1,2,3]] ? [[2,3],[1]] ? [[1,3],[2]] ? [[3],[1,2]] ? [[3],[2],[1]]) -- The sum of the length of the sublists is the length of the argument list: partitionLengths xs = sum (map length (partition xs)) <~> length xs -- The sublists of the partition and the argument list have the same elements: partitionElems xs = anyOf (map anyOf (partition xs)) <~> anyOf xs -- end module Combinatorial curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/CurryStringClassifier.curry000066400000000000000000000232111305333611600266150ustar00rootroot00000000000000---------------------------------------------------------------------- --- The Curry string classifier is a simple tool to process strings containing --- Curry source code. The source string is classified into the following --- categories: --- --- * moduleHead - module interface, imports, operators --- --- * code - the part where the actual program is defined --- --- * big comment - parts enclosed in {- ... -} --- --- * small comment - from "--" to the end of a line --- --- * text - a string, i.e. text enclosed in "..." --- --- * letter - the given string is the representation of a character --- --- * meta - containing information for meta programming --- --- For an example to use the state scanner cf. addtypes, the tool --- to add function types to a given program. --- --- @author Bernd Brassel --- @version April 2005 --- @category meta ---------------------------------------------------------------------- module CurryStringClassifier (Tokens,Token(..), scan, plainCode, unscan, isSmallComment, isBigComment, isComment, isText, isLetter, isCode, isModuleHead, isMeta, readScan,testScan) where import Char(isDigit,isSpace) --- The different categories to classify the source code. data Token = SmallComment String | BigComment String | Text String | Letter String | Code String | ModuleHead String | Meta String type Tokens = [Token] --- test for category "SmallComment" isSmallComment x = case x of SmallComment _ -> True _ -> False --- test for category "BigComment" isBigComment x = case x of BigComment _ -> True _ -> False --- test if given token is a comment (big or small) isComment x = isSmallComment x || isBigComment x --- test for category "Text" (String) isText x = case x of Text _ -> True _ -> False --- test for category "Letter" (Char) isLetter x = case x of Letter _ -> True _ -> False --- test for category "Code" isCode x = case x of Code _ -> True _ -> False --- test for category "ModuleHead", ie imports and operator declarations isModuleHead x = case x of ModuleHead _ -> True _ -> False --- test for category "Meta", ie between {+ and +} isMeta x = case x of Meta _ -> True _ -> False weaveIntoCode :: (Tokens -> Tokens) -> Tokens -> Tokens weaveIntoCode f ts = let (cs,ncs) = unweaveCode ts in weave (f cs,ncs) unweaveCode :: Tokens -> (Tokens,Tokens) unweaveCode [] = ([],[]) unweaveCode (t:ts) = let (cs,ncs) = unweaveCode ts in if isCode t then (t:cs,ncs) else (cs,t:ncs) weave xys = case xys of ([],[]) -> [] ([],[y]) -> [y] ([x],[]) -> [x] (x:xs,y:ys) -> x:y:weave (xs,ys) --- Divides the given string into the six categories. --- For applications it is important to know whether a given part of --- code is at the beginning of a line or in the middle. The state scanner --- organizes the code in such a way that every string categorized as --- "Code" always starts in the middle of a line. scan :: [Char] -> Tokens scan s = modHead id (stateScan 1 (Code x) x s) where x free stateScan :: Int -> Token -> [Char] -> [Char] -> Tokens stateScan _ token x "" | x=:="" = [token] stateScan _ (Code co) x [c] | x=:=[c] = maybeCode co [] stateScan _ (Text t) x [c] | x=:="" = if c=='\"' then [Text t] else error "File ended while scanning string." stateScan _ (BigComment _) x [_] | x=:="" = error "File ended while expecting -}" stateScan _ (Meta _) x [_] | x=:="" = error "File ended while expecting +}" stateScan line (Code co) x (c:c':cs) | c=='\"' = (x=:="") &> (maybeCode co (stateScan line (Text y) y (c':cs))) | c=='-' && c'=='-' = let (comment,rest) = span (/='\n') cs in (x=:="") &> maybeCode co (SmallComment comment : (stateScan line (Code y) y rest)) | c=='{' && c'=='-' = (x=:="") &> maybeCode co (stateScan line (BigComment y) y cs) | c=='{' && c'=='+' = (x=:="") &> maybeCode co (stateScan line (Meta y) y cs) | c'=='\'' && elem c (infixIDs++delimiters) = (x=:=[c]) &> maybeCode co $ case cs of '\\':l:'\'':rest -> Letter ['\\',l] : (stateScan line (Code y) y rest) '\\':a:b:d:'\'':rest -> if all isDigit [a,b,d] then Letter ['\\',a,b,d] : (stateScan line (Code y) y rest) else error $ "Improperly terminated character found in line " ++ show line l:'\'':rest -> Letter [l] : (stateScan line (Code y) y rest) _ -> error $ "Improperly terminated character in line "++show line | c=='\n' = (x=:=c:y) &> stateScan (line+1) (Code co) y (c':cs) | otherwise = (x=:=c:y) &> stateScan line (Code co) y (c':cs) where y free stateScan line (BigComment co) x (c:c':cs) | c=='-' && c'=='}' = (x=:="") &> BigComment co : (stateScan line (Code y) y cs) | c=='\n' = (x=:=c:y) &> stateScan (line+1) (BigComment co) y (c':cs) | otherwise = (x=:=c:y) &> stateScan line (BigComment co) y (c':cs) where y free stateScan line (Meta co) x (c:c':cs) | c=='+' && c'=='}' = (x=:="") &> Meta co : (stateScan line (Code y) y cs) | c=='\n' = (x=:=c:y) &> stateScan (line+1) (Meta co) y (c':cs) | otherwise = (x=:=c:y) &> stateScan line (Meta co) y (c':cs) where y free stateScan line (Text t) x (c:c':cs) | c == '\"' = (x=:="") &> Text t : (stateScan line (Code y) y (c':cs)) | c == '\\' = (x=:=c:c':y) &> stateScan line (Text t) y cs | elem c toBeEscaped = error $ "unescaped "++c:" encountered in line " ++ show line | otherwise = (x=:=c:y) &> stateScan line (Text t) y (c':cs) where y free modHead :: ([Char] -> [Char]) -> Tokens -> Tokens modHead fs (Code c : ts) = case break (\x->x=='\n'||x=='\r') c of ("","") -> modHead fs ts ("",n:rest) -> modHead (fs . (n:)) (Code rest : ts) (line,"") -> if any (lineBeginsWith line) headers then ModuleHead (fs line) : (modHeadInLine id ts) else maybeMo (fs "") (Code c:ts) (line,n:rest)-> if any (lineBeginsWith line) headers then modHead (fs . (line++) . (n:)) (Code rest:ts) else maybeMo (fs "") (Code c : ts) modHead fs (BigComment c : ts) = maybeMo (fs "") (BigComment c : (modHead id ts)) modHead fs (SmallComment c : ts) = maybeMo (fs "") (SmallComment c : (modHead id ts)) modHead fs (Meta c : ts) = maybeMo (fs "") (Meta c : ts) modHead fs [] = maybeMo (fs "") [] modHeadInLine :: ([Char] -> [Char]) -> Tokens -> Tokens modHeadInLine fs [] = maybeMo (fs "") [] modHeadInLine fs (Code c : ts) = case break (\x->x=='\n'||x=='\r') c of (line,n:rest) -> modHead (fs . (line++) . (n:)) (Code rest : ts) _ -> modHead fs (Code c : ts) modHeadInLine fs (BigComment c : ts) = maybeMo (fs "") (BigComment c : (modHeadInLine id ts)) modHeadInLine fs (SmallComment c : ts) = maybeMo (fs "") (SmallComment c : (modHeadInLine id ts)) modHeadInLine fs (Meta c : ts) = maybeMo (fs "") (Meta c : ts) headers :: [[Char]] headers = [" ","import","infix","infixl","infixr","module"] lineBeginsWith :: [Char] -> [Char] -> Bool lineBeginsWith line s | length line < lens = False | otherwise = line==s || let (s',rest) = splitAt (length s) line in s==s' && (null rest || isSep (head rest)) where lens = length s isSep :: Char -> Bool isSep c = isSpace c || elem c infixIDs || elem c "([{" infixIDs :: String infixIDs = "~!@#$%^&*+-=<>?./|\\:" delimiters :: String delimiters = " ([{,}])" toBeEscaped :: [Char] toBeEscaped = "\\\n\r\t\"" maybeCode :: [Char] -> Tokens -> Tokens maybeCode s ts = {-if s=="" then ts else-} Code s:ts maybeMo s ts = if s=="" then ts else ModuleHead s:case ts of Code c:ts' -> Code ('\n':c):ts' _ -> ts --- Yields the program code without comments --- (but with the line breaks for small comments). plainCode :: Tokens -> String plainCode (ModuleHead s:ts) = case ts of Code c : ts' -> s++drop 1 c++plainCode ts' _ -> s++plainCode ts plainCode (Code s:ts) = s++plainCode ts plainCode (Text s:ts) = '\"':s++'\"':plainCode ts plainCode (Letter s:ts) = '\'':s++'\'':plainCode ts plainCode (BigComment _:ts) = plainCode ts plainCode (SmallComment _:ts) = plainCode ts plainCode (Meta s:ts) = "{+"++s++"+}"++plainCode ts plainCode [] = "" --- Inverse function of scan, i.e., unscan (scan x) = x. --- unscan is used to yield a program after changing the list of tokens. unscan :: Tokens -> String unscan (ModuleHead s:ts) = s++case ts of (Code (_:c):ts') -> unscan (Code c:ts') _ -> unscan ts unscan (Code s:ts) = s++unscan ts unscan (Text s:ts) = '\"':s++'\"':unscan ts unscan (Letter s:ts) = '\'':s++'\'':unscan ts unscan (BigComment s:ts) = "{-"++s++"-}"++unscan ts unscan (SmallComment s:ts) = "--"++s++unscan ts unscan (Meta s:ts) = "{+"++s++"+}"++unscan ts unscan [] = "" --- return tokens for given filename readScan :: [Char] -> IO Tokens readScan fn = readFile fn >>= return . scan --- test whether (unscan . scan) is identity testScan :: [Char] -> IO () testScan fn = do c <- readFile fn print (unscan (scan c)==c) testWeave :: [Char] -> IO () testWeave fn = do c <- readFile fn print (unscan (weave (unweaveCode (scan c)))==c) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Database.curry.pakcs000066400000000000000000000251771305333611600251360ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for accessing and storing data in databases. --- The contents of a database is represented in this library --- as dynamic predicates that are defined by facts than can change over --- time and can be persistently stored. --- All functions in this library distinguishes between queries that --- access the database and transactions that manipulates data --- in the database. Transactions have a monadic structure. --- Both queries and transactions can be executed as I/O actions. --- However, arbitrary I/O actions cannot be embedded in transactions. --- --- A dynamic predicate p with arguments of type --- t1,...,tn must be declared by: --- --- p :: t1 -> ... -> tn -> Dynamic
--- p = dynamic --- --- --- A dynamic predicate where all facts should be persistently stored --- in the directory DIR must be declared by: --- --- p :: t1 -> ... -> tn -> Dynamic
--- p = persistent "file:DIR" --- --- @author Michael Hanus --- @version August 2011 --- @category database ------------------------------------------------------------------------------ module Database(Dynamic,dynamic,persistent,(<>),(|&>),(|>), Query,queryOne,queryAll,queryOneWithDefault,queryJustOne, dynamicExists,transformQ,runQ, Transaction,TError(..),TErrorKind(..),showTError, addDB,deleteDB,getDB, (|>>),(|>>=),returnT,doneT,errorT,failT, sequenceT,sequenceT_,mapT,mapT_,runT,runJustT,runTNA) where import Dynamic import Global -- to store transaction errors infixl 1 |>>, |>>= ------------------------------------------------------------------------------ -- Database queries: --- Abstract datatype to represent database queries. data Query a = QueryDB (IO a) --- A database query that returns all answers to an abstraction on a --- dynamic expression. queryAll :: (a -> Dynamic) -> Query [a] queryAll dynq = QueryDB (getDynamicSolutions dynq) --- A database query that returns a single answer to an abstraction on a --- dynamic expression. It returns Nothing if no answer exists. queryOne :: (a -> Dynamic) -> Query (Maybe a) queryOne dynq = QueryDB (getDynamicSolution dynq) --- A database query that returns a single answer to an abstraction on a --- dynamic expression. It returns the first argument if no answer exists. queryOneWithDefault :: a -> (a -> Dynamic) -> Query a queryOneWithDefault d dynq = transformQ (maybe d id) (queryOne dynq) --- A database query that returns a single answer to an abstraction on a --- dynamic expression. It fails if no answer exists. queryJustOne :: (a -> Dynamic) -> Query a queryJustOne = queryOneWithDefault failed --- A database query that returns True if there exists the argument facts --- (without free variables!) and False, otherwise. dynamicExists :: Dynamic -> Query Bool dynamicExists dyn = QueryDB (isKnown dyn) --- Transforms a database query from one result type to another --- according to a given mapping. transformQ :: (a -> b) -> Query a -> Query b transformQ f (QueryDB a) = QueryDB (a >>= return . f) --- Executes a database query on the current state of dynamic predicates. --- If other processes made changes to persistent predicates, --- these changes are read and made visible to the currently running program. runQ :: Query a -> IO a runQ (QueryDB q) = q ------------------------------------------------------------------------------ -- Transactions: --- The type of errors that might occur during a transaction. data TError = TError TErrorKind String --- The various kinds of transaction errors. data TErrorKind = KeyNotExistsError | NoRelationshipError | DuplicateKeyError | KeyRequiredError | UniqueError | MinError | MaxError | UserDefinedError | ExecutionError --- Transforms a transaction error into a string. showTError :: TError -> String showTError (TError k s) = "Transaction error " ++ show k ++ ": " ++ s --- Abstract datatype for representing transactions. data Transaction a = TransDB (IO (TransResult a)) -- Internal type for representing the result of a transaction. data TransResult a = OK a | Error TError --- Adds new facts (without free variables!) about dynamic predicates. --- Conditional dynamics are added only if the condition holds. addDB :: Dynamic -> Transaction () addDB dyn = TransDB (Dynamic.assert dyn >> return (OK ())) --- Deletes facts (without free variables!) about dynamic predicates. --- Conditional dynamics are deleted only if the condition holds. deleteDB :: Dynamic -> Transaction () deleteDB dyn = TransDB (Dynamic.retract dyn >> return (OK ())) --- Returns the result of a database query in a transaction. getDB :: Query a -> Transaction a getDB (QueryDB q) = TransDB (q >>= \qresult -> return (OK qresult)) --- The empty transaction that directly returns its argument. returnT :: a -> Transaction a returnT x = TransDB (return (OK x)) --- The empty transaction that returns nothing. doneT :: Transaction () doneT = returnT () --- Abort a transaction with a specific transaction error. errorT :: TError -> Transaction _ errorT e = TransDB (return (Error e)) --- Abort a transaction with a general error message. failT :: String -> Transaction _ failT s = errorT (TError UserDefinedError s) --- Sequential composition of transactions. --- @param a - a transaction --- @param fa - a function from a value into a transaction --- @return a transaction that first performs a --- (yielding result r) --- and then performs (fa r) (|>>=) :: Transaction a -> (a -> Transaction b) -> Transaction b (TransDB t1) |>>= ft = TransDB $ do r1 <- t1 case r1 of Error e -> return (Error e) OK t1value -> let TransDB t2 = ft t1value in t2 --- Sequential composition of transactions. --- @param a1 - a transaction --- @param a2 - a transaction --- @return a transaction that first performs a1 and then a2 (|>>) :: Transaction _ -> Transaction a -> Transaction a t1 |>> t2 = t1 |>>= \_ -> t2 --- Executes a sequence of transactions and collects all results in a list. sequenceT :: [Transaction a] -> Transaction [a] sequenceT [] = returnT [] sequenceT (t:ts) = t |>>= \x -> sequenceT ts |>>= \xs -> returnT (x:xs) --- Executes a sequence of transactions and ignores the results. sequenceT_ :: [Transaction _] -> Transaction () sequenceT_ = foldr (|>>) doneT --- Maps a transaction function on a list of elements. --- The results of all transactions are collected in a list. mapT :: (a -> Transaction b) -> [a] -> Transaction [b] mapT f = sequenceT . map f --- Maps a transaction function on a list of elements. --- The results of all transactions are ignored. mapT_ :: (a -> Transaction _) -> [a] -> Transaction () mapT_ f = sequenceT_ . map f --- Executes a possibly composed transaction on the current state --- of dynamic predicates as a single transaction. --- --- Before the transaction is executed, the access to all persistent --- predicates is locked (i.e., no other process can perform a --- transaction in parallel). --- After the successful transaction, the access is unlocked so that --- the updates performed in this transaction become persistent and --- visible to other processes. --- Otherwise (i.e., in case of a failure or abort of the transaction), --- the changes of the transaction to persistent predicates are --- ignored and Nothing is returned. --- --- In general, a transaction should terminate and all failures inside --- a transaction should be handled (execept for an explicit failT --- that leads to an abort of the transaction). --- If a transaction is externally interrupted (e.g., by killing the process), --- some locks might never be removed. However, they --- can be explicitly removed by deleting the corresponding lock files --- reported at startup time. runT :: Transaction a -> IO (Either a TError) runT t = do writeGlobal currentTransError execError etr <- Dynamic.transactionWithErrorCatch (let TransDB trans = t in trans >>= \tresult -> case tresult of OK _ -> return tresult Error e -> writeGlobal currentTransError e >> failed) either (return . transformResult) (\re -> readGlobal currentTransError >>= \e -> return (Right (if e==execError then TError ExecutionError (showError re) else e))) etr where transformResult (OK x) = Left x transformResult (Error e) = Right e --- Executes a possibly composed transaction on the current state --- of dynamic predicates as a single transaction. --- Similarly to runT but a run-time error is raised --- if the execution of the transaction fails. runJustT :: Transaction a -> IO a runJustT t = runT t >>= return . either id (\e -> error ("Transaction failed: " ++ showTError e)) --- Executes a possibly composed transaction as a Non-Atomic(!) --- sequence of its individual database updates. --- Thus, the argument is not executed as a single transaction --- in contrast to runT, i.e., no predicates are --- locked and individual updates are not undone in case of a --- transaction error. --- This operation could be applied to execute a composed transaction --- without the overhead caused by (the current implementation of) --- transactions if one is sure that locking is not necessary --- (e.g., if the transaction contains only database reads and --- transaction error raising). runTNA :: Transaction a -> IO (Either a TError) runTNA t = do writeGlobal currentTransError execError etr <- safeExecIO (let TransDB trans = t in trans >>= \tresult -> case tresult of OK _ -> return tresult Error e -> writeGlobal currentTransError e >> failed) either (return . transformResult) (\re -> readGlobal currentTransError >>= \e -> return (Right (if e==execError then TError ExecutionError (showError re) else e))) etr where transformResult (OK x) = Left x transformResult (Error e) = Right e safeExecIO :: IO a -> IO (Either a IOError) safeExecIO action = catch (action >>= return . Left) (return . Right) -- Global entity to store the transaction error during the execution of -- the transaction. currentTransError :: Global TError currentTransError = global execError Temporary execError = TError ExecutionError "run-time error during transaction execution" curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Database/000077500000000000000000000000001305333611600227345ustar00rootroot00000000000000curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Database/CDBI/000077500000000000000000000000001305333611600234355ustar00rootroot00000000000000curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Database/CDBI/Connection.curry000066400000000000000000000474371305333611600266410ustar00rootroot00000000000000--- ---------------------------------------------------------------------------- --- This module defines basis data types and functions for accessing --- database systems using SQL. Currently, only SQLite3 is supported, --- but this is easy to extend. It also provides execution of SQL-Queries --- with types. Allowed datatypes for these queries are defined and --- the conversion to standard SQL-Queries is provided. --- --- @author Mike Tallarek --- @version 0.2 --- @category database --- ---------------------------------------------------------------------------- module Database.CDBI.Connection ( -- Basis types and operations SQLValue(..), SQLType(..), SQLResult, fromSQLResult, printSQLResults , DBAction, DBError (..), DBErrorKind (..), Connection (..) -- DBActions , runInTransaction, fail, ok, (>+), (>+=), executeRaw, execute, select , executeMultipleTimes, getColumnNames, valueToString -- Connections , connectSQLite, disconnect, begin, commit, rollback, runWithDB ) where import Char ( isDigit ) import Function ( on ) import Global ( Global, GlobalSpec(..), global, readGlobal, writeGlobal ) import IOExts ( connectToCommand ) import IO ( Handle, hPutStrLn, hGetLine, hFlush, hClose, stderr ) import List ( insertBy, isInfixOf, isPrefixOf, tails ) import ReadShowTerm ( readsQTerm ) import ReadNumeric ( readInt ) import System ( system ) import Time --- Global flag for database debug mode. --- If on, all communication with database is written to stderr. dbDebug :: Bool dbDebug = False -- ----------------------------------------------------------------------------- -- Datatypes -- ----------------------------------------------------------------------------- --- The result of SQL-related actions. It is either a `DBError` or some value. type SQLResult a = Either DBError a --- Gets the value of an 'SQLResult'. If there is no result value --- but a database error, the error is raised. fromSQLResult :: SQLResult a -> a fromSQLResult (Left err) = error $ "Database connection error: " ++ show err fromSQLResult (Right val) = val --- Print an 'SQLResult' list, i.e., print either the 'DBError' --- or the list of result elements. printSQLResults :: SQLResult [_] -> IO () printSQLResults (Left err) = putStrLn $ show err printSQLResults (Right res) = mapIO_ print res --- `DBError`s are composed of an `DBErrorKind` and a `String` --- describing the error more explicitly. data DBError = DBError DBErrorKind String --- The different kinds of errors. data DBErrorKind = TableDoesNotExist | ParameterError | ConstraintViolation | SyntaxError | NoLineError | LockedDBError | UnknownError --- Data type for SQL values, used during the communication with the database. data SQLValue = SQLString String | SQLInt Int | SQLFloat Float | SQLChar Char | SQLBool Bool | SQLDate ClockTime | SQLNull --- Type identifiers for `SQLValue`s, necessary to determine the type --- of the value a column should be converted to. data SQLType = SQLTypeString | SQLTypeInt | SQLTypeFloat | SQLTypeChar | SQLTypeBool | SQLTypeDate --- A DBAction takes a connection and returns an `IO (SQLResult a)`. type DBAction a = Connection -> IO (SQLResult a) -- ----------------------------------------------------------------------------- -- Database actions with types -- ----------------------------------------------------------------------------- --- Run a `DBAction` as a transaction. --- In case of an `Error` it will rollback all changes, otherwise the changes --- are committed. --- @param act - The `DBAction` --- @param conn - The `Connection` to the database on which the transaction --- shall be executed. runInTransaction :: DBAction a -> DBAction a runInTransaction act conn = do begin conn res <- act conn case res of Left _ -> rollback conn >> return res Right _ -> commit conn >> return res --- Connect two `DBAction`s. --- When executed this function will execute the first `DBAction` --- and then execute the second applied to the first result --- An `Error` will stop either action. --- @param x - The `DBAction` that will be executed first --- @param y - The `DBAction` hat will be executed afterwards --- @return A `DBAction` that wille execute both `DBAction`s. --- The result is the result of the second `DBAction`. (>+=) :: DBAction a -> (a -> DBAction b) -> DBAction b m >+= f = \conn -> do v1 <- m conn case v1 of Right val -> f val conn Left err -> return (Left err) --- Connect two DBActions, but ignore the result of the first. (>+) :: DBAction a -> DBAction b -> DBAction b (>+) x y = x >+= (\_ -> y) --- Failing action. fail :: DBError -> DBAction a fail err _ = return (Left err) --- Successful action. ok :: a -> DBAction a ok val _ = return (Right val) --- execute a query where the result of the execution is returned --- @param query - The SQL Query as a String, might have '?' as placeholder --- @param values - A list of SQLValues that replace the '?' placeholder --- @param types - A list of SQLTypes that describe the types of the --- result-tables (e.g. "select * from exampletable" and [SQLTypeInt, --- SQLTypeFloat, SQLTypeString] --- when the table exampletable has three columns of type Int, Float and --- String.) The order of the list has to be the same as the order of the --- columns in the table --- @param conn - A Connection to a database where the query will be executed --- @return A Result with a list of SQLValues which types correspond to --- the SQLType-List that was given as a parameter if the execution was --- successful, otherwise an Error select :: String -> [SQLValue] -> [SQLType] -> DBAction [[SQLValue]] select query values types conn = (executeRaw query (valuesToString values) >+= (\a _ -> return (convertValues a types))) conn --- execute a query without a result --- @param query - The SQL Query as a String, might have '?' as placeholder --- @param values - A list of SQLValues that replace the '?' placeholder --- @param conn - A Connection to a database where the query will be executed --- @return An empty if the execution was successful, otherwise an error execute :: String -> [SQLValue] -> DBAction () execute query values conn = (executeRaw query (valuesToString values) >+ (\_ -> return (Right ()))) conn --- execute a query multiple times with different SQLValues without a result --- @param query - The SQL Query as a String, might have '?' as placeholder --- @param values - A list of lists of SQLValues that replace the '?' placeholder --- (One list for every execution) --- @param conn - A Connection to a database where the query will be executed --- @return A empty Result if every execution was successful, otherwise an --- Error (meaning at least one execution failed). As soon as one --- execution fails the rest wont be executed. executeMultipleTimes :: String -> [[SQLValue]] -> DBAction () executeMultipleTimes query values conn = do result <- foldl (\res row -> (res >>= \x -> case x of Right _ -> execute query row conn error -> return error)) (return (Right ())) values return result -- ----------------------------------------------------------------------------- -- Database connections -- ----------------------------------------------------------------------------- --- Data type for database connections. --- Currently, only connections to a SQLite3 database are supported, --- but other types of connections could easily be added. --- List of functions that would need to be implemented: --- A function to connect to the database, disconnect, writeConnection --- readRawConnection, parseLines, begin, commit, rollback and getColumnNames data Connection = SQLiteConnection Handle --- Connect to a SQLite Database --- @param str - name of the database (e.g. "database.db") --- @return A connection to a SQLite Database connectSQLite :: String -> IO Connection connectSQLite db = do exsqlite3 <- system "which sqlite3 > /dev/null" when (exsqlite3>0) $ error "Database interface `sqlite3' not found. Please install package `sqlite3'!" h <- connectToCommand $ "sqlite3 " ++ db hPutAndFlush h ".mode line" hPutAndFlush h ".log stdout" return $ SQLiteConnection h --- Disconnect from a database. disconnect :: Connection -> IO () disconnect (SQLiteConnection h) = hClose h hPutAndFlush :: Handle -> String -> IO () hPutAndFlush h s = do when dbDebug $ hPutStrLn stderr ("DB>>> " ++ s) hPutStrLn h s >> hFlush h --- Write a `String` to a `Connection`. writeConnection :: String -> Connection -> IO () writeConnection str (SQLiteConnection h) = hPutAndFlush h str --- Read a `String` from a `Connection`. readRawConnection :: Connection -> IO String readRawConnection (SQLiteConnection h) = if dbDebug then do inp <- hGetLine h hPutStrLn stderr ("DB<<< " ++ inp) return inp else hGetLine h --- Begin a Transaction. begin :: Connection -> IO () begin conn@(SQLiteConnection _) = writeConnection "begin;" conn --- Commit a Transaction. commit :: Connection -> IO () commit conn@(SQLiteConnection _) = writeConnection "commit;" conn --- Rollback a Transaction. rollback :: Connection -> IO () rollback conn@(SQLiteConnection _) = writeConnection "rollback;" conn --- Executes an action dependent on a connection on a database --- by connecting to the datebase. The connection will be kept open --- and re-used for the next action to this database. --- @param str - name of the database (e.g. "database.db") --- @param action - an action parameterized over a database connection --- @return the result of the action runWithDB :: String -> (Connection -> IO a) -> IO a runWithDB dbname dbaction = ensureSQLiteConnection dbname >>= dbaction --- Executes an action dependent on a connection on a database --- by connecting and disconnecting to the datebase. --- @param str - name of the database (e.g. "database.db") --- @param action - an action parameterized over a database connection --- @return the result of the action runWithDB' :: String -> (Connection -> IO a) -> IO a runWithDB' dbname dbaction = do conn <- connectSQLite dbname result <- dbaction conn disconnect conn return result -- ----------------------------------------------------------------------------- -- Executing SQL statements -- ----------------------------------------------------------------------------- --- Execute a SQL statement. --- The statement may contain '?' placeholders and a list of parameters which --- should be inserted at the respective positions. --- The result is a list of list of strings where every single list --- represents a row of the result. executeRaw :: String -> [String] -> DBAction [[String]] executeRaw query para conn = do let queryInserted = (insertParams query para) case queryInserted of Left err -> return $ Left err Right qu -> do writeConnection qu conn parseLines conn --- Returns a list with the names of every column in a table --- The parameter is the name of the table and a connection getColumnNames :: String -> DBAction [String] -- SQLite Implementation getColumnNames table conn@(SQLiteConnection _) = do writeConnection ("pragma table_info(" ++ table ++ ");") conn result <- parseLines conn case result of Left err -> return (Left err) Right xs -> return (Right (map retrieveColumnNames xs)) where retrieveColumnNames :: [String] -> String retrieveColumnNames (_:y:_) = y --- Read every output line of a Connection and return a Result with a list --- of lists of Strings where every list of Strings represents a row. --- NULL-Values have to be empty Strings instead of "NULL", all other --- values should be represented exactly as they're saved in the database parseLines :: DBAction [[String]] --- SQLite Implementation parseLines conn@(SQLiteConnection _) = do random <- getRandom case random of Left err -> fail err conn Right val -> do writeConnection ("select '" ++ val ++ "';") conn parseLinesUntil val conn --- `getRandom` requests a random number from a SQLite-database. getRandom :: IO (SQLResult String) getRandom = do conn <- ensureSQLiteConnection "" -- connectSQLite "" writeConnection "select hex(randomblob(8));" conn result <- readConnection conn --disconnect conn return result --- Inserts parameters into a SQL query for placeholders denoted by (`?`). --- The parameters are inserted in the order in which they are supplied. --- Will throw error if the number of placeholders isn't equal to the length --- of the list insertParams :: String -> [String] -> SQLResult String insertParams qu xs = if (length xs == (countPlaceholder qu)) then Right (insertParams' qu xs) else Left (DBError ParameterError "Amount of placeholders not equal to length of placeholder-list") where insertParams' sql [] = sql insertParams' sql params@(p:ps) = case sql of "" -> "" ''':'?':''':cs -> p ++ insertParams' cs ps c:cs -> c : insertParams' cs params countPlaceholder qu2 = case qu2 of "" -> 0 ''':'?':''':cs -> 1 + (countPlaceholder cs) _:cs -> countPlaceholder cs --- Reads the current output of sqlite line for line until a specific --- `String` is met. This is necessary because it is otherwise not possible --- to determine the end of the output without blocking. (SQLite-Function) parseLinesUntil :: String -> DBAction [[String]] parseLinesUntil stop conn@(SQLiteConnection _) = next where next = do value <- readConnection conn case value of Left (DBError NoLineError "") -> do rest <- next case rest of Left err -> fail err conn Right xs -> ok ([]:xs) conn Left err -> readRawConnection conn >> fail err conn Right val | val == "index" -> next | val == stop -> ok [[]] conn | otherwise -> do rest <- next case rest of Left err -> fail err conn Right ([]:xs) -> ok ([val]:xs) conn Right ((x:ys):xs) -> ok ((val:(x:ys)):xs) conn --- Read a line from a SQLite Connection and check if it represents a value readConnection :: DBAction String readConnection conn@(SQLiteConnection _) = do check `liftIO` readRawConnection conn where --- Ensure that a line read from a database connection represents a value. check :: String -> SQLResult String check str | null str = Left (DBError NoLineError "") | "Error" `isPrefixOf` str = Left (DBError (getErrorKindSQLite str) str) | '=' `elem` str = Right (getValue str) | "automatic index on" `isInfixOf` str = Right "index" | otherwise = Left (DBError (getErrorKindSQLite str) str) --- Get the value from a line with a '=' getValue :: String -> String --getValue (_ ++ "= " ++ b) = b --getValue (_ ++ "=") = "" -- alternative implementation to avoid non-deterministic functional patterns: getValue s = if "case" `isInfixOf` s then getCaseValue s else let taileq = tail (snd (break (== '=') s)) in if null taileq then "" else let (' ':val) = taileq in val where getCaseValue str = getValue (readTilEnd str) readTilEnd rest = head (filter (\ls -> "end" `isPrefixOf` ls) (tails rest)) --- Identify the error kind. getErrorKindSQLite :: String -> DBErrorKind getErrorKindSQLite str | "Error: UNIQUE constraint" `isPrefixOf` str = ConstraintViolation | "no such table" `isInfixOf` str = TableDoesNotExist | "syntax error" `isInfixOf` str = SyntaxError | "Error: database is locked" `isInfixOf` str = LockedDBError | otherwise = UnknownError -- ----------------------------------------------------------------------------- -- Auxiliary Functions -- ----------------------------------------------------------------------------- -- Converts SQLValues to their String representation valuesToString :: [SQLValue] -> [String] valuesToString xs = map valueToString xs valueToString :: SQLValue -> String valueToString x = replaceEmptyString $ case x of SQLString a -> "'" ++ doubleApostrophes a ++ "'" SQLChar a -> "'" ++doubleApostrophes [a] ++ "'" SQLNull -> "NULL" SQLDate a -> "'" ++ show (toUTCTime a) ++ "'" SQLInt a -> show a--"'" ++ show a ++ "'" SQLFloat a -> show a --"'" ++ show a ++ "'" SQLBool a -> "'" ++ show a ++ "'" -- Replaces an empty String with "NU'LL" replaceEmptyString :: String -> String replaceEmptyString str = case str of "''" -> "NULL" st -> st -- Converts Stringrepresentations of SQLValues to their SQLValues -- Every list of Strings in the first parameter represents a data-type -- of multiple values -- The list of SQLTypes tells the function what kind of SQLValues should be parsed convertValues :: [[String]] -> [SQLType] -> SQLResult [[SQLValue]] convertValues (s:str) types = if((length s) == (length types)) then Right (map (\x -> map convertValuesHelp (zip x types)) (s:str)) else if ((length s) == 0) then Right [] else Left (DBError ParameterError "Number of returned Parameters and Types not equal") convertValuesHelp :: (String,SQLType) -> SQLValue convertValuesHelp ([], SQLTypeString) = SQLNull convertValuesHelp ((s:str), SQLTypeString) = (SQLString (s:str)) convertValuesHelp (s, SQLTypeInt) = case (readInt s) of Just (a,_) -> (SQLInt a) Nothing -> SQLNull convertValuesHelp (s, SQLTypeFloat) = if isFloat s then case (readsQTerm s) of [] -> SQLNull ((a,_):_) -> SQLFloat a else SQLNull convertValuesHelp (s, SQLTypeBool) = case (readsQTerm s) of [(True,[])] -> SQLBool True [(False,[])] -> SQLBool False _ -> SQLNull convertValuesHelp (s, SQLTypeDate) = case (readsQTerm s) of [((CalendarTime a b c d e f g),[])] -> SQLDate (toClockTime (CalendarTime a b c d e f g)) _ -> SQLNull convertValuesHelp ("", SQLTypeChar) = SQLNull convertValuesHelp (s:_, SQLTypeChar) = SQLChar s -- replace all Apostrophes in a string with a doubled apostrophe doubleApostrophes :: String -> String doubleApostrophes (s:str) = if s == '\'' then ("''" ++ (doubleApostrophes str)) else (s : (doubleApostrophes str)) doubleApostrophes "" = "" -- Does the String represent a Float? isFloat :: String -> Bool isFloat [a] = isDigit a isFloat (a:b:_) = (isDigit a) || (isDigit b && a == '-') isFloat [] = False ----------------------------------------------------------------------------- -- A global value that keeps all open database handles. openDBConnections :: Global [(String,Connection)] openDBConnections = global [] Temporary -- Connect to SQLite database. Either create a new connection -- (and keep it) or re-use a previous connection. ensureSQLiteConnection :: String -> IO Connection ensureSQLiteConnection db = do dbConnections <- readGlobal openDBConnections maybe (addNewConnection dbConnections) return (lookup db dbConnections) where addNewConnection dbConnections = do dbcon <- connectSQLite db writeGlobal openDBConnections $ -- sort against deadlock insertBy ((<=) `on` fst) (db,dbcon) dbConnections return dbcon -- Performs an action on all open database connections. withAllDBConnections :: (Connection -> IO _) -> IO () withAllDBConnections f = readGlobal openDBConnections >>= mapIO_ (f . snd) --- Closes all database connections. Should be called when no more --- database access will be necessary. closeDBConnections :: IO () closeDBConnections = do withAllDBConnections disconnect writeGlobal openDBConnections [] ----------------------------------------------------------------------------- curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Database/CDBI/Criteria.curry000066400000000000000000000417141305333611600262740ustar00rootroot00000000000000--- ---------------------------------------------------------------------------- --- This module provides datatypes, constructor functions and translation --- functions to specify SQL criteria including options(group-by, having, order-by) --- --- @author Mike Tallarek, Julia Krone --- @version 0.2 --- @category database --- ---------------------------------------------------------------------------- module Database.CDBI.Criteria ( Criteria(..), Constraint(..), ColVal(..), GroupBy, Option, Value(..), CValue, CColumn, Condition(..), Specifier(..), emptyCriteria, int, float, char, string, bool, date, col, idVal, colNum, colVal, colValAlt, isNull, isNotNull, equal, (.=.), notEqual, (./=.), greaterThan, (.>.), lessThan, (.<.), greaterThanEqual, (.<=.), lessThanEqual, (.>=.), like, (.~.), between, isIn, (.<->.), toCValue, toCColumn, ascOrder, descOrder, groupBy, having, groupByCol, trCriteria, trConstraint, trCondition, trValue, trColumn,trSpecifier, trOption, sumIntCol, sumFloatCol, countCol, avgIntCol, avgFloatCol, minCol, maxCol, condition, noHave) where import List (intercalate) import Time (ClockTime) import Database.CDBI.Connection (SQLValue (..), SQLType(..), valueToString) import Database.CDBI.Description (Column (..), Table) -- ----------------------------------------------------------------------------- -- Datatypes for constructing SQL criteria -- ----------------------------------------------------------------------------- --- Criterias for queries that can have a constraint and a group-by clause data Criteria = Criteria Constraint (Maybe GroupBy) --- specifier for queries data Specifier = Distinct | All --- datatype to represent order-by statement data Option = AscOrder CValue | DescOrder CValue --- datatype to represent group-by statement data GroupBy = GroupBy CValue GroupByTail --- subtype for additional columns or having-Clause in group-by statement data GroupByTail = Having Condition | GBT CValue GroupByTail | NoHave --- datatype for conditions inside a having-clause data Condition = Con Constraint | Fun String Specifier Constraint | HAnd [Condition] | HOr [Condition] | Neg Condition --- A datatype to compare values. --- Can be either a SQLValue or a Column with an additional --- Integer (rename-number). The Integer is for dealing with renamed --- tables in queries (i.e. Students as 1Students). If the Integer n is 0 --- the column will be named as usual ("Table"."Column"), otherwise it will --- be named "nTable"."Column" in the query This is for being able to do --- complex "where exists" constraints data Value a = Val SQLValue | Col (Column a) Int --- A datatype thats a combination between a Column and a Value --- (Needed for update queries) data ColVal = ColVal CColumn CValue --- Type for columns used inside a constraint. type CColumn = Column () --- Type for values used inside a constraint. type CValue = Value () --- Constraints for queries --- Every constructor with at least one value has a function as a constructor --- and only that function will be exported to assure type-safety --- Most of these are just like the Sql-where-commands Exists needs the --- table-name, an integer and maybe a constraint --- (where exists (select * from table where constraint)) --- The integer n will rename the table if it has a different value than 0 --- (where exists (select * from table as ntable where...)) data Constraint = IsNull CValue | IsNotNull CValue | BinaryRel RelOp CValue CValue | Between CValue CValue CValue | IsIn CValue [CValue] | Not Constraint | And [Constraint] | Or [Constraint] | Exists Table Int Constraint | None data RelOp = Eq | Neq | Lt | Lte | Gt | Gte | Like -- ----------------------------------------------------------------------------- -- Constructor functions -- ----------------------------------------------------------------------------- --- An empty criteria emptyCriteria :: Criteria emptyCriteria = Criteria None Nothing --- Constructor for a Value Val of type Int --- @param i - The value int :: Int -> Value Int int = Val . SQLInt --- Constructor for a Value Val of type Float --- @param i - The value float :: Float -> Value Float float = Val . SQLFloat --- Constructor for a Value Val of type Char --- @param i - The value char :: Char -> Value Char char = Val . SQLChar --- Constructor for a Value Val of type String --- @param i - The value string :: String -> Value String string = Val . SQLString --- Constructor for a Value Val of type Bool --- @param i - The value bool :: Bool -> Value Bool bool = Val . SQLBool --- Constructor for a Value Val of type ClockTime --- @param i - The value date :: ClockTime -> Value ClockTime date = Val . SQLDate --- Constructor for Values of ID-types --- Should just be used internally! idVal :: Int -> Value _ idVal i = Val (SQLInt i) val :: SQLValue -> Value _ val v = (Val v) --- Constructor for a Value Col without a rename-number --- @param c - The column col :: Column a -> Value a col c = Col c 0 --- Constructor for a Value Col with a rename-number --- @param c - The column --- @param n - The rename-number colNum :: Column a -> Int -> Value a colNum c n = Col c n --- A constructor for ColVal needed for typesafety --- @param c - The Column --- @param v - The Value colVal :: Column a -> Value a -> ColVal colVal c v = ColVal (toCColumn c) (toCValue v) --- Alternative ColVal constructor without typesafety --- @param table - The Tablename of the column --- @param cl - The column name --- @param s - The SQLValue colValAlt :: String -> String -> SQLValue -> ColVal colValAlt table cl s = ColVal (toCColumn (Column ("\"" ++ cl ++ "\"") ("\"" ++ table ++ "\".\"" ++ "\"" ++ cl ++ "\""))) (Val s) --- IsNull construnctor --- @param v1 - First Value isNull :: Value a -> Constraint isNull v1 = IsNull (toCValue v1) --- IsNotNull construnctor --- @param v1 - First Value isNotNull :: Value a -> Constraint isNotNull v1 = IsNotNull (toCValue v1) --- Equal construnctor --- @param v1 - First Value --- @param v2 - Second Value equal :: Value a -> Value a -> Constraint equal v1 v2 = BinaryRel Eq (toCValue v1) (toCValue v2) --- Infix Equal (.=.) :: Value a -> Value a -> Constraint (.=.) = equal --- NotEqual construnctor --- @param v1 - First Value --- @param v2 - Second Value notEqual :: Value a -> Value a -> Constraint notEqual v1 v2 = BinaryRel Neq (toCValue v1) (toCValue v2) --- Infix NotEqual (./=.) :: Value a -> Value a -> Constraint (./=.) = notEqual --- GreatherThan construnctor --- @param v1 - First Value --- @param v2 - Second Value greaterThan :: Value a -> Value a -> Constraint greaterThan v1 v2 = BinaryRel Gt (toCValue v1) (toCValue v2) --- Infix GreaterThan (.>.) :: Value a -> Value a -> Constraint (.>.) = greaterThan --- LessThan construnctor --- @param v1 - First Value --- @param v2 - Second Value lessThan :: Value a -> Value a -> Constraint lessThan v1 v2 = BinaryRel Lt (toCValue v1) (toCValue v2) --- Infix LessThan (.<.) :: Value a -> Value a -> Constraint (.<.) = lessThan --- GreaterThanEqual construnctor --- @param v1 - First Value --- @param v2 - Second Value greaterThanEqual :: Value a -> Value a -> Constraint greaterThanEqual v1 v2 = BinaryRel Gte (toCValue v1) (toCValue v2) --- Infix GreaterThanEqual (.>=.) :: Value a -> Value a -> Constraint (.>=.) = greaterThanEqual --- LessThanEqual construnctor --- @param v1 - First Value --- @param v2 - Second Value lessThanEqual :: Value a -> Value a -> Constraint lessThanEqual v1 v2 = BinaryRel Lte (toCValue v1) (toCValue v2) --- Infix LessThanEqual (.<=.) :: Value a -> Value a -> Constraint (.<=.) = lessThanEqual --- Like construnctor --- @param v1 - First Value --- @param v2 - Second Value like :: Value a -> Value a -> Constraint like v1 v2 = BinaryRel Like (toCValue v1) (toCValue v2) --- Infix Like (.~.) :: Value a -> Value a -> Constraint (.~.) = like --- Between construnctor --- @param v1 - First Value --- @param v2 - Second Value --- @param v3 - Third Value between :: Value a -> Value a -> Value a -> Constraint between v1 v2 v3 = Between (toCValue v1) (toCValue v2) (toCValue v3) --- IsIn construnctor --- @param v1 - First Value --- @param xs - List of Values isIn :: Value a -> [Value a] -> Constraint isIn v1 xs = IsIn (toCValue v1) (map toCValue xs) --- Infix IsIn (.<->.) :: Value a -> [Value a] -> Constraint (.<->.) = isIn --- Constructor for the option: Ascending Order by Column --- @param c - The Column that should be ordered by ascOrder :: Value a -> Option ascOrder v = AscOrder (toCValue v) --- Constructor for the option: Descending Order by Column --- @param c - The Column that should be ordered by descOrder :: Value a -> Option descOrder v = DescOrder (toCValue v) ---Constructor for group-by-clause ---@param c - The Column that should be grouped by ---@param gbTail - GroupByTail, i.e. more columns or a having-clause groupBy :: Value a -> GroupByTail -> GroupBy groupBy c gbTail = GroupBy (toCValue c) gbTail --- Constructor to specifiy more than one column for group-by --- @param c - the additional column --- @param gbTail - subsequent part of group-by statement groupByCol :: Value a -> GroupByTail -> GroupByTail groupByCol c gbTail = GBT (toCValue c) gbTail ---Constructor for having condition ---@param con - The condition having :: Condition -> GroupByTail having con = Having con --- Constructor for empty having-Clause noHave :: GroupByTail noHave = NoHave ---Constructor for Condition with just a simple Constraint condition :: Constraint -> Condition condition con = Con con ---Constructor for aggregation function sum for columns of type Int --- having-clauses. ---@param spec - specifier Distinct or All ---@param c - Column that is to be summed up ---@param v - value the result is compared to (has to be of type Int) ---@param op - relating operator sumIntCol :: Specifier -> Value Int -> Value Int -> (Value () -> Value () -> Constraint) -> Condition sumIntCol spec c v op = (Fun "Sum " spec (op (toCValue c) (toCValue v))) --- Constructor for aggregation function sum for columns of type float --- in having-clauses. ---@param spec - specifier Distinct or All ---@param c - Column that is to be summed up ---@param v - value the result is compared to (has to be of type float) ---@param op - relating operator sumFloatCol :: Specifier -> Value Float -> Value Float -> (Value () -> Value () -> Constraint) -> Condition sumFloatCol spec c v op = (Fun "Sum " spec (op (toCValue c) (toCValue v))) --- Constructor for aggregation function avg for columns of type Int --- in having-clauses. ---@param spec - specifier Distinct or All ---@param c - Column that is to be averaged ---@param v - value the result is compared to (has to be of type float) ---@param op - relating operator avgIntCol :: Specifier -> Value Int -> Value Float -> (Value () -> Value () -> Constraint) -> Condition avgIntCol spec c v op = (Fun "Avg " spec (op (toCValue c) (toCValue v))) --- Constructor for aggregation function avg for columns of type float --- in having-clauses. ---@param spec - specifier Distinct or All ---@param c - Column that is to be avaraged ---@param v - value the result is compared to (has to be of type float) ---@param op - relating operator avgFloatCol :: Specifier -> Value Float -> Value Float -> (Value () -> Value () -> Constraint) -> Condition avgFloatCol spec c v op = (Fun "Avg " spec (op (toCValue c) (toCValue v))) ---Constructor for aggregation function count in having-clauses. ---@param spec - specifier Distinct or All ---@param c - Column which elements are to be counted ---@param v - value the result is compared to (has to be of type Int). ---@param op - relating operator countCol :: Specifier -> Value _ -> Value Int -> (Value () -> Value () -> Constraint) -> Condition countCol spec c v op = (Fun "Count " spec (op (toCValue c) (toCValue v))) --- Constructor for aggregation function min in having-clauses. --- @param spec - specifier Distinct or All ---@param c - column the minimal element has to be extracted from ---@param v - value to compare to the minimal value, same type as column ---@param op - operator minCol :: Specifier -> Value a -> Value a -> (Value () -> Value () -> Constraint) -> Condition minCol spec c v op = (Fun "Min " spec (op (toCValue c) (toCValue v))) --- Constructor for aggregation function max in having-clauses. --- @param spec - specifier Distinct or All ---@param c - column the maximal element has to be extracted from ---@param v - value to compare to the maximal value, same type as column ---@param op - operator maxCol :: Specifier -> Value a -> Value a -> (Value () -> Value () -> Constraint) -> Condition maxCol spec c v op = (Fun "Max " spec (op (toCValue c) (toCValue v))) --Convert to UnitType toCColumn :: Column a -> Column () toCColumn (Column s1 s2) = (Column s1 s2) toCValue :: Value a -> CValue toCValue (Col (Column s1 s2) n) = Col (Column s1 s2) n toCValue (Val v1) = Val v1 -- ----------------------------------------------------------------------------- -- Translation of a constraint into a SQL string. -- ----------------------------------------------------------------------------- -- Translate Criteria to a string in a sql-query trCriteria :: Criteria -> String trCriteria crit = case crit of (Criteria None group) -> trGroup group (Criteria c group) -> " where " ++ trConstraint c ++ " " ++ trGroup group -- Translate an Order-by to a string in a sql-query trOption :: [Option] -> String trOption [] = "" trOption (ls@((AscOrder _):_)) = " order by " ++ intercalate ", " (map trOption' ls) trOption (ls@((DescOrder _):_)) = " order by " ++ intercalate ", " (map trOption' ls) trOption' :: Option -> String trOption' (AscOrder v) = trValue v ++ " asc" trOption' (DescOrder v) = trValue v ++ " desc" -- translate a group-by to a string in a sql-query trGroup :: (Maybe GroupBy) -> String trGroup Nothing = "" trGroup (Just (GroupBy cs gbTail)) = " group by " ++ trValue cs ++ trTail gbTail trTail :: GroupByTail -> String trTail (GBT cs gbTail) = ", "++ trValue cs ++ trTail gbTail trTail NoHave = "" trTail (Having cond) = " Having " ++ trCondition cond trCondition :: Condition -> String trCondition (HAnd conds) = intercalate " and " (map trCondition conds) trCondition (HOr conds) = intercalate " or " (map trCondition conds) trCondition (Con cons) = trConstraint cons trCondition (Neg cond) = "(not "++ (trCondition cond)++")" trCondition (Fun fun spec cons) = "("++fun ++ "("++trSpecifier spec ++constr where ('(':'(':constr) = trConstraint cons -- Translate a Constraint to a string in a sql-query trConstraint :: Constraint -> String trConstraint (IsNull v) = paren $ (paren $ trValue v) ++ " is NULL" trConstraint (IsNotNull v) = paren $ (paren $ trValue v) ++ " is not NULL" trConstraint (BinaryRel rel v1 v2) = paren $ (paren $ trValue v1) ++ trRelOp rel ++ trValue v2 trConstraint (Between v1 v2 v3) = paren $ (paren $ trValue v1) ++ " between " ++ trValue v2 ++ " and " ++ trValue v3 trConstraint (IsIn v vs) = paren $ trValue v ++ " in " ++ paren (intercalate ", " $ map trValue vs) trConstraint (Not c) = paren $ "not " ++ trConstraint c trConstraint (And [] ) = "" trConstraint (And cs@(_:_)) = paren $ intercalate " and " (map trConstraint cs) trConstraint (Or [] ) = "" trConstraint (Or cs@(_:_)) = paren $ intercalate " or " (map trConstraint cs) trConstraint (Exists table n cs) = "(exists (select * from '" ++ table ++ "' " ++ (asTable table n) ++ " " ++ (trCriteria (Criteria cs Nothing)) ++ "))" trRelOp :: RelOp -> String trRelOp Eq = " == " trRelOp Neq = " <> " trRelOp Lt = " < " trRelOp Lte = " <= " trRelOp Gt = " > " trRelOp Gte = " >= " trRelOp Like = " like " -- Translate a Value to a String trValue :: Value a -> String trValue (Val v) = valueToString v trValue (Col (Column _ c) n) = trColumn c n -- Translate "Table.Column" to "nTable.Colum" where n is the Integer-Parameter trColumn :: String -> Int -> String trColumn ('"':table_column) n = if n==0 then '"' : table_column else '"' : show n ++ table_column {- trColumn ("\"" ++ table ++ "\"." ++ column) n = case n of 0 -> "\"" ++ table ++ "\"." ++ column m -> "\"" ++ (show m) ++ table ++ "\"." ++ column -} paren :: String -> String paren s = '(' : s ++ ")" -- Create the "as tablename" string asTable :: Table -> Int -> Table asTable table n = case n of 0 -> "" m -> " as '" ++ (show m) ++ table ++ "'" --Translate specifier trSpecifier :: Specifier -> String trSpecifier All = "" trSpecifier Distinct = "Distinct "curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Database/CDBI/Description.curry000066400000000000000000000224211305333611600270070ustar00rootroot00000000000000--- This module contains basic datatypes and operations to represent --- a relational data model in a type-safe manner. This representation is --- used by the library `Database.CDBI.ER` to provide type safety --- when working with relational databases. --- The tool `erd2cdbi` generates from an entity-relationship model --- a Curry program that represents all entities and relationships --- by the use of this module. --- --- @author Mike Tallarek, changes by Julia Krone --- @version 0.2 --- @category database --- ---------------------------------------------------------------------------- module Database.CDBI.Description where import Time import Database.CDBI.Connection (SQLType, SQLValue(..)) -- ----------------------------------------------------------------------------- -- Datatypes for describing entities -- ----------------------------------------------------------------------------- --- The datatype EntityDescription is a description of a database entity --- type including the name, the types the entity consists of, a function --- transforming an instance of this entity to a list of SQLValues, a --- second function doing the same but converting the key value always to --- SQLNull to ensure that keys are auto incrementing and a --- function transforming a list of SQLValues to an instance of this entity data EntityDescription a = ED String [SQLType] (a -> [SQLValue]) (a -> [SQLValue]) --for insertion ([SQLValue] -> a) --- Entity-types can be combined (For Example Student and Lecture could be --- combined to Data StuLec = StuLec Student Lecture). If a description for --- this new type is written CDBI can look up that type in the database --- The description is a list of Tuples consisting of a String (The name of --- the entity type that will be combined), a "rename-number" n which will --- rename the table to "table as ntable" and a list of SQLTypes (The types --- that make up that entity type). Furthermore there has to be a function --- that transform a list of SQLValues into this combined type, and two --- functions that transform the combined type into a list of SQLValues, the --- first one for updates, the second one for insertion. --- The list of sqlvalues needs to match what is returned by the database. data CombinedDescription a = CD [(Table, Int, [SQLType])] ([SQLValue] -> a) (a -> [[SQLValue]]) (a -> [[SQLValue]]) -- for insertion --- A type representing tablenames type Table = String --- A datatype representing column names. --- The first string is the simple name of the column (for example the --- column Name of the row Student). The second string is the name of the --- column combined with the name of the row (for example Student.Name). --- These names should always be in quotes (for example "Student"."Name") --- so no errors emerge (the name "Group" for --- example would result in errors if not in quotes). --- Has a phantom-type for the value the column represents. data Column _ = Column String String --- Datatype representing columns for selection. --- This datatype has to be distinguished from type Column which is just for --- definition of conditions. --- The type definition consists of the complete name (including tablename), --- the SQLType of the column --- and two functions for the mapping from SQLValue into the resulttype and --- the other way around data ColumnDescription a = ColDesc String SQLType (a -> SQLValue) (SQLValue -> a) --- A constructor for CombinedDescription. --- @param ed1 - Description of the first Entity-Type that is to be combined --- @param rename1 - The "rename-number" for ed1. If it is zero ed1 will --- not be renamed in queries, otherwise is will be renamed as --- follows: "table as ntable" --- @param ed2 - Description of the second Entity-Type that is to be combined --- @param rename2 - Same as rename1 for ed2 --- @param f - A function that describes how the combined entity is built. --- Takes two entities that make up the combined entity as parameters --- and combines those into the combined entity. combineDescriptions :: EntityDescription a -> Int -> EntityDescription b -> Int -> (a -> b -> c) -> (c -> (a, b)) -> CombinedDescription c combineDescriptions ed1 rename1 ed2 rename2 f1 f2 = CD [(getTable ed1, rename1, getTypes ed1), (getTable ed2, rename2, getTypes ed2)] createFunction1 createFunction2 createFunction3 where createFunction1 xs = f1 ((getToEntity ed1) (take lengthEd1 xs)) ((getToEntity ed2) (drop lengthEd1 xs)) where lengthEd1 = length (getTypes ed1) createFunction2 combEnt = let (ent1, ent2) = f2 combEnt in ((getToValues ed1) ent1) : [(getToValues ed2) ent2] createFunction3 combEnt = let (ent1, ent2) = f2 combEnt in ((getToInsertValues ed1) ent1) : [(getToInsertValues ed2) ent2] --- Adds another ED to an already existing CD. --- @param ed1 - The ED to be added --- @param rename - The "rename-number" --- @param f1 - A function that describes how the combined entity is built. --- Takes the entity that should be added and the combined entity as parameter --- and combines those into a new version of the combined entity. --- @param cd - The already existing CD addDescription :: EntityDescription a -> Int -> (a -> b -> b) -> (b -> a) -> CombinedDescription b -> CombinedDescription b addDescription ed1 rename f1 f2 (CD xs f1' f2' f3') = CD ((getTable ed1, rename, getTypes ed1) : xs) createFunction1 createFunction2 createFunction3 where createFunction1 ys = f1 ((getToEntity ed1) (take lengthEd1 ys)) (f1' (drop lengthEd1 ys)) where lengthEd1 = length (getTypes ed1) createFunction2 combEnt = [(getToValues ed1) (f2 combEnt)] ++ (f2' combEnt) createFunction3 combEnt = [(getToInsertValues ed1) (f2 combEnt)] ++ (f3' combEnt) -- ----------------------------------------------------------------------------- -- Auxiliary Functions -- ----------------------------------------------------------------------------- getTable :: EntityDescription a -> String getTable (ED s _ _ _ _) = s getTypes :: EntityDescription a -> [SQLType] getTypes (ED _ t _ _ _) = t getToValues :: EntityDescription a -> (a -> [SQLValue]) getToValues (ED _ _ f _ _) = f getToInsertValues :: EntityDescription a -> (a -> [SQLValue]) getToInsertValues (ED _ _ _ f _) = f getToEntity :: EntityDescription a -> ([SQLValue] -> a) getToEntity (ED _ _ _ _ f) = f getColumnSimple :: Column a -> String getColumnSimple (Column s _ ) = s getColumnFull :: Column a -> String getColumnFull (Column _ s ) = s getColumnName :: ColumnDescription a -> String getColumnName (ColDesc s _ _ _) = s getColumnTableName :: ColumnDescription a -> String getColumnTableName (ColDesc s _ _ _) = s getColumnTyp :: ColumnDescription a -> SQLType getColumnTyp (ColDesc _ t _ _) = t getColumnValueBuilder :: ColumnDescription a -> (a -> SQLValue) getColumnValueBuilder (ColDesc _ _ f _) = f getColumnValueSelector :: ColumnDescription a -> (SQLValue -> a) getColumnValueSelector (ColDesc _ _ _ f) = f -- Conversion functions toValueOrNull :: (a -> SQLValue) -> Maybe a -> SQLValue toValueOrNull _ Nothing = SQLNull toValueOrNull f (Just v) = f v sqlIntOrNull :: (Maybe Int) -> SQLValue sqlIntOrNull Nothing = SQLNull sqlIntOrNull (Just a) = SQLInt a sqlFloatOrNull :: (Maybe Float) -> SQLValue sqlFloatOrNull Nothing = SQLNull sqlFloatOrNull (Just a) = SQLFloat a sqlCharOrNull :: (Maybe Char) -> SQLValue sqlCharOrNull Nothing = SQLNull sqlCharOrNull (Just a) = SQLChar a sqlStringOrNull :: (Maybe String) -> SQLValue sqlStringOrNull Nothing = SQLNull sqlStringOrNull (Just a) = SQLString a sqlString :: String -> SQLValue sqlString a = SQLString a sqlBoolOrNull :: (Maybe Bool) -> SQLValue sqlBoolOrNull Nothing = SQLNull sqlBoolOrNull (Just a) = SQLBool a sqlDateOrNull :: (Maybe ClockTime) -> SQLValue sqlDateOrNull Nothing = SQLNull sqlDateOrNull (Just a) = SQLDate a intOrNothing :: SQLValue -> (Maybe Int) intOrNothing SQLNull = Nothing intOrNothing (SQLInt a) = Just a floatOrNothing :: SQLValue -> (Maybe Float) floatOrNothing SQLNull = Nothing floatOrNothing (SQLFloat a) = Just a charOrNothing :: SQLValue -> (Maybe Char) charOrNothing SQLNull = Nothing charOrNothing (SQLChar a) = Just a stringOrNothing :: SQLValue -> (Maybe String) stringOrNothing SQLNull = Nothing stringOrNothing (SQLString a) = Just a fromStringOrNull :: SQLValue -> String fromStringOrNull SQLNull = "" fromStringOrNull (SQLString a) = a boolOrNothing :: SQLValue -> (Maybe Bool) boolOrNothing SQLNull = Nothing boolOrNothing (SQLBool a) = Just a dateOrNothing :: SQLValue -> (Maybe ClockTime) dateOrNothing SQLNull = Nothing dateOrNothing (SQLDate a) = Just acurry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Database/CDBI/ER.curry000066400000000000000000000554411305333611600250420ustar00rootroot00000000000000--- ---------------------------------------------------------------------------- --- This is the main CDBI-module. It provides datatypes and functions to --- do Database-Queries working with Entities (ER-Model) --- @author Mike Tallarek, extensions by Julia Krone, Michael Hanus --- --- @version 0.2 --- @category database --- ---------------------------------------------------------------------------- module Database.CDBI.ER ( -- Database Functions saveEntry, saveMultipleEntries, saveEntryCombined, insertEntry, insertEntries, restoreEntries, getEntries, getEntriesCombined, updateEntries, deleteEntries, insertEntryCombined, updateEntry, updateEntryCombined, getColumn, getColumnTuple, getColumnTriple, getColumnFourTuple, getColumnFiveTuple, --CDBI.Connection DBAction, Connection, SQLResult, printSQLResults, runInTransaction, (>+), (>+=), begin, commit, rollback, connectSQLite, disconnect, runWithDB, -- Datatypes EntityDescription, Value, ColumnDescription, Join, SetOp(..), Specifier(..), Table, SingleColumnSelect(..), TupleColumnSelect(..), TripleColumnSelect(..), FourColumnSelect(..), FiveColumnSelect(..), TableClause(..), CombinedDescription, combineDescriptions, addDescription, innerJoin, crossJoin, caseThen, sum, avg, minV, maxV, none, count, singleCol, tupleCol, tripleCol, fourCol, fiveCol, int, float, char, string, bool, date, col, colNum, colVal, -- CDBI.Criteria Criteria(..), emptyCriteria, Constraint(Exists, Or, And, Not, None), isNull, isNotNull, equal, (.=.), notEqual, (./=.), greaterThan, (.>.), lessThan, (.<.), greaterThanEqual, (.>=.), lessThanEqual, (.<=.), like, (.~.), between, isIn, (.<->.), Option, ascOrder, descOrder, groupBy, groupByCol, having, condition, noHave, Condition(..), sumIntCol, sumFloatCol, countCol, avgIntCol, avgFloatCol, minCol, maxCol, caseResultInt, caseResultFloat, caseResultString, caseResultChar, caseResultBool) where import List (intercalate, nub) import Time (ClockTime) import Database.CDBI.Connection import Database.CDBI.Criteria import Database.CDBI.Description import Database.CDBI.QueryTypes -- ----------------------------------------------------------------------------- -- Database functions with Entities -- ----------------------------------------------------------------------------- --- Inserts an entry into the database. --- @param a - The entry to save --- @param en - The EntityDescription that describes the entity to be saved --- @param conn - A Connection to a database which will be used for this --- @return A Result without parameter if saving worked or an Error if there --- was a problem insertEntry :: a -> EntityDescription a -> DBAction () insertEntry a en conn = do let query = ("insert into '" ++ (getTable en) ++ "' values("++ (questionmarks en) ++");") execute query ((getToInsertValues en) a) conn --- Saves an entry to the database (only for backward compatibility). saveEntry :: a -> EntityDescription a -> DBAction () saveEntry = insertEntry --- Inserts several entries into the database. --- @param xs - The list of entries to save --- @param en - The EntityDescription that describes the entities to be saved --- @param conn - A Connection to a database which will be used for this --- @return A Result without parameter if saving worked or an Error if there --- was a problem. If one saving operation reports an error, every following --- saving operation will be aborted but every saving operation up to that --- point will be executed. If these executed saving operations should also --- be discarded withTransaction or begin/commit/rollback should be used insertEntries :: [a] -> EntityDescription a -> DBAction () insertEntries xs en conn = do let query = ("insert into '" ++ (getTable en) ++ "' values("++ (questionmarks en) ++");") executeMultipleTimes query (map (getToInsertValues en) xs) conn --- Saves multiple entries to the database (only for backward compatibility). saveMultipleEntries :: [a] -> EntityDescription a -> DBAction () saveMultipleEntries = insertEntries --- Stores entries with their current keys in the database. --- It is an error if entries with the same key are already in the database. --- Thus, this operation is useful only to restore a database with saved data. --- @param xs - The list of entries to save --- @param en - The EntityDescription that describes the entities to be saved --- @param conn - A Connection to a database which will be used for this --- @return A Result without parameter if saving worked or an Error if there --- was a problem. If one saving operation reports an error, every following --- saving operation will be aborted but every saving operation up to that --- point will be executed. If these executed saving operations should also --- be discarded withTransaction or begin/commit/rollback should be used restoreEntries :: [a] -> EntityDescription a -> DBAction () restoreEntries xs en conn = do let query = ("insert into '" ++ (getTable en) ++ "' values("++ (questionmarks en) ++");") executeMultipleTimes query (map (getToValues en) xs) conn --- Gets entries from the database. --- @param spec - Specifier All or Distinct --- @param en - The EntityDescription that describes the entity --- @param crit - Criteria for the query --- @param op - oreder-by clause --- @param limit - int value to limit number of entities returned --- @param conn - A Connection to a database which will be used for this --- @return A Result with a list of entries as parameter or an Error --- if something went wrong. getEntries :: Specifier -> EntityDescription a -> Criteria -> [Option] -> Maybe Int -> DBAction [a] getEntries spec en crit op limit conn = do let query = "select " ++ trSpecifier spec ++"* from '" ++ getTable en ++ "' " ++ trCriteria crit ++ trOption op ++ trLimit limit ++";" ((select query [] (getTypes en)) >+= (\vals _ -> return $ Right (map (getToEntity en) vals))) conn --- Gets a single Column from the database. --- @param setops - list of Setoperators to combine queries if more than one is --- given, can be empty otherwise --- @param sels - list of SingleColumnSelects to specify query, --- if there are more requests than can be combined with --- setoperators they will be ignored ---@param options - order-by-clause for whole query ---@param limit - value to reduce number of returned rows ---@param conn - A Connection to a database which will be used for this ---@return A Result with a list of a-Values as parameter --- (where a is the type of the column) or an Error --- if something went wrong. getColumn :: [SetOp] -> [SingleColumnSelect a] -> [Option] -> Maybe Int -> DBAction [a] getColumn _ [] _ _ _ = return $ Right [] getColumn setops (s:sels) options limit conn = do let query = ((foldl (\quest (so, sel) -> quest ++ (trSetOp so) ++ (trSingleSelectQuery sel) ) (trSingleSelectQuery s) (zip setops sels)) ++ trOption options ++ trLimit limit++" ;") ((select query [] (getSingleType s)) >+= (\vals _ -> return $ Right (map ((getSingleValFunc s). head) vals))) conn --- Gets two Columns from the database. --- @param setops - list of Setoperators to combine queries if more than one is --- given, can be empty otherwise --- @param sels - list of TupleColumnSelects to specify queries, if there --- are more requests than can be combined with setoperators --- they will be ignored ---@param options - order-by-clause for whole query ---@param limit - value to reduce number of returned rows ---@param conn - A Connection to a database which will be used for this ---@return A Result with a list of a-Values as parameter --- (where a is the type of the column) or an Error --- if something went wrong. getColumnTuple :: [SetOp] -> [TupleColumnSelect a b] -> [Option] -> Maybe Int -> DBAction [(a,b)] getColumnTuple _ [] _ _ _ = return $ Right [] getColumnTuple setops (s:sels) options limit conn = do let query = ((foldl (\quest (so, sel) -> quest ++ (trSetOp so) ++ (trTupleSelectQuery sel) ) (trTupleSelectQuery s) (zip setops sels)) ++ trOption options ++ trLimit limit++" ;") let (fun1, fun2) = getTupleValFuncs s ((select query [] (getTupleTypes s)) >+= (\vals _ -> return $ Right (map (\[val1, val2] -> ((fun1 val1),(fun2 val2))) vals))) conn --- Gets three Columns from the database. --- @param setops - list of Setoperators to combine queries if more than one is --- given, can be empty otherwise --- @param sels - list of TripleColumnSelects to specify queries, if there --- are more requests than can be combined with setoperators --- they will be ignored ---@param options - order-by-clause for whole query ---@param limit - value to reduce number of returned rows ---@param conn - A Connection to a database which will be used for this ---@return A Result with a list of a-Values as parameter --- (where a is the type of the column) or an Error --- if something went wrong. getColumnTriple :: [SetOp] -> [TripleColumnSelect a b c] -> [Option] -> Maybe Int -> DBAction [(a,b,c)] getColumnTriple _ [] _ _ _ = return $ Right [] getColumnTriple setops (s:sels) options limit conn = do let query = ((foldl (\quest (so, sel) -> quest ++ (trSetOp so) ++ (trTripleSelectQuery sel) ) (trTripleSelectQuery s) (zip setops sels)) ++ trOption options ++ trLimit limit++" ;") let (fun1, fun2, fun3) = getTripleValFuncs s ((select query [] (getTripleTypes s)) >+= (\vals _ -> return $ Right (map (\[val1, val2, val3] -> ((fun1 val1), (fun2 val2), (fun3 val3))) vals))) conn --- Gets four Columns from the database. --- @param setops - list of Setoperators to combine queries if more than one is --- given, can be empty otherwise --- @param sels - list of FourColumnSelects to specify queries, if there --- are more requests than can be combined with setoperators --- they will be ignored ---@param options - order-by-clause for whole query ---@param limit - value to reduce number of returned rows ---@param conn - A Connection to a database which will be used for this ---@return A Result with a list of a-Values as parameter --- (where a is the type of the column) or an Error --- if something went wrong. getColumnFourTuple :: [SetOp] -> [FourColumnSelect a b c d] -> [Option] -> Maybe Int -> DBAction [(a,b,c,d)] getColumnFourTuple _ [] _ _ _ = return $ Right [] getColumnFourTuple setops (s:sels) options limit conn = do let query = ((foldl (\quest (so, sel) -> quest ++ (trSetOp so) ++ (trFourTupleSelectQuery sel)) (trFourTupleSelectQuery s) (zip setops sels)) ++ trOption options ++ trLimit limit++" ;") let (fun1, fun2, fun3, fun4) = getFourTupleValFuncs s ((select query [] (getFourTupleTypes s)) >+= (\vals _ -> return $ Right (map (\[val1, val2, val3, val4] -> ((fun1 val1), (fun2 val2), (fun3 val3), (fun4 val4))) vals))) conn --- Gets five Columns from the database. --- @param setops - list of Setoperators to combine queries if more than one is --- given, can be empty otherwise --- @param sels - list of FiveColumnSelects to specify queries, if there --- are more requests than can be combined with setoperators --- they will be ignored ---@param options - order-by-clause for whole query ---@param limit - value to reduce number of returned rows ---@param conn - A Connection to a database which will be used for this ---@return A Result with a list of a-Values as parameter --- (where a is the type of the column) or an Error --- if something went wrong. getColumnFiveTuple :: [SetOp] -> [FiveColumnSelect a b c d e] -> [Option] -> Maybe Int -> DBAction [(a,b,c,d,e)] getColumnFiveTuple _ [] _ _ _ = return $ Right [] getColumnFiveTuple setops (s:sels) options limit conn = do let query = ((foldl (\quest (so, sel) -> quest ++ (trSetOp so) ++ (trFiveTupleSelectQuery sel)) (trFiveTupleSelectQuery s) (zip setops sels)) ++ trOption options ++ trLimit limit++" ;") let (fun1, fun2, fun3, fun4, fun5) = getFiveTupleValFuncs s ((select query [] (getFiveTupleTypes s)) >+= (\vals _ -> return $ Right (map (\[val1, val2, val3, val4, val5] -> ((fun1 val1), (fun2 val2), (fun3 val3), (fun4 val4), (fun5 val5))) vals))) conn --- Gets combined entries from the database. --- @param spec - Specifier Distinct or All --- @param cd - The CombinedDescription that describes the entity --- @param joins - joins to combine the entity, they will be applied --- in a left-associative manner --- @param crit - Criteria for the query --- @param op - order-by-clause --- @param limit - int value to determine number of values returned --- @param conn - A Connection to a database which will be used for this --- @return A Result with a list of entries as parameter or an Error --- if something went wrong. getEntriesCombined :: Specifier -> CombinedDescription a -> [Join] -> Criteria -> [Option] -> Maybe Int -> DBAction [a] getEntriesCombined spec cd@(CD _ f _ _) joins crit op limit conn = do let query = "select "++ trSpecifier spec ++ "* from " ++ (getJoinString cd joins) ++ " " ++ (trCriteria crit) ++ trOption op ++ trLimit limit ++ ";" result <- select query [] (getJoinTypes cd) conn case result of Right xs -> return $ Right $ map f xs Left err -> return $ Left err --- Inserts combined entries. --- @param a - The combined Entity to be saved --- @param cd - The CombinedDescription that describes the entity --- @param conn - A Connection to a database which will be used for this --- @return A Result without parameter if saving worked or an Error if there --- was a problem insertEntryCombined :: a -> CombinedDescription a -> DBAction () insertEntryCombined ent (CD desc _ _ f3) conn = foldIO save (Right _) (zip desc (f3 ent)) where save :: SQLResult () -> ((Table, Int, [SQLType]), [SQLValue]) -> IO (SQLResult ()) save res ((table, _, types), vals) = do case res of Left err -> return (Left err) Right _ -> do let query = ("insert into '" ++ table ++ "' values(" ++ (questionmarksHelp (length types)) ++");") execute query vals conn --- Saves combined entries (for backward compatibility). saveEntryCombined :: a -> CombinedDescription a -> DBAction () saveEntryCombined = insertEntryCombined --- Updates entries depending on wether they fulfill the criteria or not --- @param en - The EntityDescription descriping the Entities that are to be --- updated --- @param xs - A list of ColVal that descripe the columns that should be --- updated and which values are to be inserted into them --- @param const - A Constraint can be be given as input which describes --- which entities should be updated. Only entities fulfilling the constraint --- will be updated. Nothing updates every entry. --- @param conn - A Connection to a database which will be used for this --- @return A Result without parameter if everything went right, --- an Error if something went wrong updateEntries :: EntityDescription a -> [ColVal] -> Constraint -> DBAction () updateEntries en xs@((ColVal cl val):ys) const conn = do let query = "update '" ++ (getTable en) ++ "' set " ++ (foldl (\a (ColVal c v) -> a ++ ", " ++ (getColumnSimple c) ++ " = " ++ (trValue v)) ((getColumnSimple cl) ++ " = " ++ (trValue val)) ys) ++ " " ++ (trCriteria (Criteria const Nothing)) ++ ";" execute query [] conn --- Updates an entry by ID. Works for Entities that have a primary key as first value. --- Function will update the entry in the --- database with the ID of the entry that is given as parameter with the values of --- the entry given as parameter --- @param entry - The entry that will be updated --- @param ed -> The EntityDescription describung the entity-type --- @param conn -> A Connection to a database which will be used for this --- @return A Result without parameter if everything went right, --- an Error if something went wrong updateEntry :: a -> EntityDescription a -> DBAction () updateEntry ent ed conn = do let table = (getTable ed) result <- getColumnNames table conn case result of Left err -> return (Left err) Right columns -> do let values = getToValues ed ent putStrLn (show values) let (SQLInt key) = head values let keycol = head columns let colvals = zipWith (colValAlt table) (tail columns) (tail values) let column = Column ("\"" ++ keycol ++ "\"") ("\"" ++ table ++ "\".\"" ++ keycol ++ "\"") let const = col column .=. int key updateEntries ed colvals const conn --- Same as updateEntry but for combined Data updateEntryCombined :: a -> CombinedDescription a -> DBAction () updateEntryCombined ent (CD desc _ f2 _) conn = foldIO update (Right ()) (zip desc (f2 ent)) where update :: SQLResult () -> ((Table, Int, [SQLType]), [SQLValue]) -> IO (SQLResult ()) update res ((table, _, _), values) = do case res of Left err -> return (Left err) Right _ -> do let (SQLInt key) = (\(x:_) -> x) values result <- getColumnNames table conn let const = ((col (Column "\"Key\"" ("\"" ++ table ++ "\".\"Key\"")) .=. (int key))) case result of Left err -> return (Left err) Right columns -> do let ((col1,val1):colval) = zip columns values execute ("update '" ++ table ++ "' set " ++ (foldl (\a (c, v) -> a ++ ", " ++ c ++ " = " ++ (valueToString v)) (col1 ++ " = " ++ (valueToString val1)) colval) ++ " " ++ (trCriteria (Criteria const Nothing)) ++ ";") [] conn --- Deletes entries depending on wether they fulfill the criteria or not --- @param en - The EntityDescription descriping the Entities that are to --- be updated --- @param const - A Constraint can be be given as input which describes --- which entities should be deleted. Only entities fulfilling the constraint --- will be deleted. Nothing deletes every entry. --- @param conn - A Connection to a database which will be used for this --- @return A Result without parameter if everything went right, an --- Error if something went wrong deleteEntries :: EntityDescription a -> (Maybe Constraint) -> DBAction () deleteEntries en const conn = do let query = "delete from '" ++ (getTable en) ++ "' " ++ (case const of Just c -> "where "++(trConstraint c) _ -> "") ++ ";" execute query [] conn --- Drops a table from the database --- @param en - The EntitiyDescription that describes the entity of which the --- table should be dropped --- @param conn - A Connection to a database which will be used for this --- @return A Result without paramter if everything went right, an Error if --- something went wrong dropTable :: EntityDescription a -> DBAction () dropTable en conn = do let query = "drop table '" ++ getTable en ++ "';" execute query [] conn -- ----------------------------------------------------------------------------- -- Auxiliary Functions -- ----------------------------------------------------------------------------- -- Create a String consisting of '?' seperated by commas corresponding to the -- number of Types an Entity has questionmarks :: EntityDescription a -> String questionmarks en = questionmarksHelp (length (getTypes en)) questionmarksHelp :: Int -> String questionmarksHelp n = intercalate ", " (replicate n "'?'") -- Create the join String of a CombinedDescription getJoinString :: CombinedDescription a -> [Join] -> String getJoinString (CD nametype _ _ _) jns= getJoinString' nametype jns where getJoinString' ((n,r,_):xs) joins = "'" ++ (foldl (\a (table, ren, _ ,join) -> a ++ (trJoinPart1 join) ++" '" ++ table ++ "'" ++ (asTable table ren) ++ (trJoinPart2 join)) (n ++ "'" ++ (asTable n r)) (mapJns xs joins)) mapJns [] _ = [] mapJns ((tb, al, t):xs) (j:js) = ((tb, al , t, j): (mapJns xs js)) -- Get the types of a CombinedDescription getJoinTypes :: CombinedDescription a -> [SQLType] getJoinTypes (CD nametype _ _ _) = getJoinString' (unzip3 nametype) where getJoinString' ((_, _, t:types)) = foldl (\a b -> a ++ b) t types curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Database/CDBI/QueryTypes.curry000066400000000000000000000444441305333611600266670ustar00rootroot00000000000000--- -------------------------------------------------------------- --- This module contains datatype declarations, constructor functions --- selectors and translation functions for complex select queries --- in particular for those selecting (1 to 5) single columns. --- @author Julia Krone --- --- @version 0.1 --- @category database --- ---------------------------------------------------------------- module Database.CDBI.QueryTypes( SetOp(..),Join(..),innerJoin, crossJoin, ColumnSingleCollection(..), ColumnTupleCollection, ColumnTripleCollection, ColumnFourTupleCollection, ColumnFiveTupleCollection, sum, avg, count, minV, maxV, none, caseThen, singleCol, tupleCol, tripleCol, fourCol, fiveCol, SingleColumnSelect(..), TupleColumnSelect(..), TripleColumnSelect(..), FourColumnSelect(..), FiveColumnSelect(..), TableClause(..), getSingleType, getTupleTypes, getTripleTypes, getFourTupleTypes, getFiveTupleTypes, getSingleValFunc, getTupleValFuncs, getTripleValFuncs, getFourTupleValFuncs, getFiveTupleValFuncs, trLimit, trSpecifier, trSetOp, trSingleSelectQuery, asTable, trTupleSelectQuery, trJoinPart1, trJoinPart2, trTripleSelectQuery, trFourTupleSelectQuery, trFiveTupleSelectQuery, caseResultInt, caseResultFloat, caseResultString, caseResultChar, caseResultBool) where import List(intercalate) import Time(ClockTime) import Database.CDBI.Connection import Database.CDBI.Criteria import Database.CDBI.Description ---datatype for set operations data SetOp = Union | Intersect | Except --- datatype for joins data Join = Cross | Inner Constraint --- Constructorfunction for an inner join ---@param constraint innerJoin :: Constraint -> Join innerJoin constraint = Inner constraint --- Constructorfunction for cross join crossJoin :: Join crossJoin = Cross --- data structure to represent a table-clause (tables and joins) --- in a way that at least one table has to be specified data TableClause = TC Table Int (Maybe (Join,TableClause)) -- Data type to specify the result type of case expressions and its conversion. type CaseVal a = (SQLType , (SQLValue -> a)) --- Datatype representing a single column in a select-clause. Can be just a --- column connected with an alias and an optional aggregation function(String) --- or a Case-when-then-statement data ColumnSingleCollection a = ResultColumnDescription (ColumnDescription a) Int String | Case Condition (CValue, CValue) (CaseVal a) --- Datatype to select two different columns which can be of different types --- and from different tables. type ColumnTupleCollection a b = (ColumnSingleCollection a, ColumnSingleCollection b) --- Datatype to select three different columns which can be of different types --- and from different tables. type ColumnTripleCollection a b c = (ColumnSingleCollection a, ColumnSingleCollection b, ColumnSingleCollection c) --- Datatype to select four different columns which can be of different types --- and from different tables. type ColumnFourTupleCollection a b c d = (ColumnSingleCollection a, ColumnSingleCollection b, ColumnSingleCollection c, ColumnSingleCollection d) --- Datatype to select five different columns which can be of different types --- and from different tables. type ColumnFiveTupleCollection a b c d e= (ColumnSingleCollection a, ColumnSingleCollection b, ColumnSingleCollection c, ColumnSingleCollection d, ColumnSingleCollection e) -- Data type to represent an aggregation function in a select-clause. type Fun a = (String , ColumnDescription a) --- Constructor for aggregation function sum --- in select-clauses. --- A pseudo-ResultColumnDescription of type --- float is created for correct return type. sum :: Specifier -> ColumnDescription _ -> Fun Float sum spec (ColDesc name _ _ _) = ("Sum( "++ (trSpecifier spec) , (ColDesc name SQLTypeFloat (\f -> (SQLFloat f)) getFloatValue)) --- Constructor for aggregation function avg --- in select-clauses. --- A pseudo-ResultColumnDescription of type --- float is created for correct return type. avg :: Specifier -> ColumnDescription _ -> Fun Float avg spec (ColDesc name _ _ _) = ("Avg( "++ (trSpecifier spec), (ColDesc name SQLTypeFloat (\f -> (SQLFloat f)) getFloatValue)) --- Constructor for aggregation function count --- in select-clauses. --- A pseudo-ResultColumnDescription of type --- float is created for correct return type. count :: Specifier -> ColumnDescription _ -> Fun Int count spec (ColDesc name _ _ _) = ("Count( "++ (trSpecifier spec), (ColDesc name SQLTypeInt (\i -> (SQLInt i)) getIntValue)) --- Constructor for aggregation function min in select-clauses. minV :: ColumnDescription a -> Fun a minV cd = ("Min( ", cd) --- Constructor for aggregation function max in select-clauses. maxV :: ColumnDescription a -> Fun a maxV cd = ("Max( ", cd) --- Constructor function in case no aggregation function is specified. none :: ColumnDescription a -> Fun a none cd = ("(", cd) ---Constructor for CaseVal of type Int ---expecting result of type Int in case-expression caseResultInt :: CaseVal Int caseResultInt = (SQLTypeInt, getIntValue) ---Constructor for CaseVal of type Float ---expecting result of type Float in case-expression caseResultFloat :: CaseVal Float caseResultFloat = (SQLTypeFloat, getFloatValue) ---Constructor for CaseVal of type String ---expecting result of type String in case-expression caseResultString :: CaseVal String caseResultString = (SQLTypeString, getStringValue) ---Constructor for CaseVal of type Date ---expecting result of type Date in case-expression caseResultDate :: CaseVal Time.ClockTime caseResultDate = (SQLTypeDate, getDateValue) ---Constructor for CaseVal of type Bool ---expecting result of type Bool in case-expression caseResultBool :: CaseVal Bool caseResultBool = (SQLTypeBool, getBoolValue) ---Constructor for CaseVal of type Char ---expecting result of type Char in case-expression caseResultChar :: CaseVal Char caseResultChar = (SQLTypeChar, getCharValue) --- Constructor function for representation of statement: --- CASE WHEN condition THEN val1 ELSE val2 END. --- It does only work for the same type in then and --- else branch. ---@param con - the condition ---@param val1 - value for then-branch ---@param val2 - value for else-branch ---@param cv - data providing SQLType and conversion function caseThen :: Condition -> Value a -> Value a -> (CaseVal a) -> ColumnSingleCollection a caseThen con val1 val2 cv = Case con ((toCValue val1), (toCValue val2)) cv --- Constructorfunction for ColumnSingleCollection. ---@param coldecs - ColumnDescription of column to select ---@param alias - alias of the table ---@param f - aggregation function (constructor) singleCol :: ColumnDescription a -> Int -> (ColumnDescription a -> Fun b) -> ColumnSingleCollection b singleCol colDesc alias f = ResultColumnDescription convColDesc alias fun where (fun, convColDesc) = f colDesc ---Constructor function for ColumnTupleCollection. ---@param col1 - first ColumnSingleCollection ---@param col2 - second ColumnSingleCollection tupleCol :: ColumnSingleCollection a -> ColumnSingleCollection b -> ColumnTupleCollection a b tupleCol col1 col2 = (col1,col2) ---Constructor function for ColumnTripleCollection. tripleCol :: ColumnSingleCollection a -> ColumnSingleCollection b -> ColumnSingleCollection c -> ColumnTripleCollection a b c tripleCol col1 col2 col3 = (col1, col2, col3) ---Constructor function for ColumnFourTupleCollection. fourCol :: ColumnSingleCollection a -> ColumnSingleCollection b -> ColumnSingleCollection c -> ColumnSingleCollection d -> ColumnFourTupleCollection a b c d fourCol col1 col2 col3 col4 = (col1, col2, col3, col4) ---Constructor function for ColumnFiveTupleCollection. fiveCol :: ColumnSingleCollection a -> ColumnSingleCollection b -> ColumnSingleCollection c -> ColumnSingleCollection d -> ColumnSingleCollection e -> ColumnFiveTupleCollection a b c d e fiveCol col1 col2 col3 col4 col5 = (col1, col2, col3, col4, col5) --- Datatype to describe all parts of a select-query without Setoperators --- order-by and limit (selecthead) for a single column. data SingleColumnSelect a = SingleCS Specifier (ColumnSingleCollection a) TableClause Criteria --- Datatype to describe all parts of a select-query without Setoperators --- order-by and limit (selecthead) for two columns. data TupleColumnSelect a b = TupleCS Specifier (ColumnTupleCollection a b) TableClause Criteria --- Datatype to describe all parts of a select-query without Setoperators --- order-by and limit (selecthead) for three columns. data TripleColumnSelect a b c = TripleCS Specifier (ColumnTripleCollection a b c) TableClause Criteria --- Datatype to describe all parts of a select-query without Setoperators --- order-by and limit (selecthead) for four columns. data FourColumnSelect a b c d = FourCS Specifier (ColumnFourTupleCollection a b c d) TableClause Criteria --- Datatype to describe all parts of a select-query without Setoperators --- order-by and limit (selecthead) for five columns. data FiveColumnSelect a b c d e = FiveCS Specifier (ColumnFiveTupleCollection a b c d e) TableClause Criteria --selector of the SQLType encasulated in a ColumnSingleCollection getColumnType :: ColumnSingleCollection _ -> [SQLType] getColumnType col = case col of (ResultColumnDescription (ColDesc _ typ _ _) _ _) -> [typ] (Case _ (_ , _) (typ,_)) -> [typ] -- selector of the conversion function encapsulated in a -- ColumnSingleCollection getColumnValFunc :: ColumnSingleCollection a -> (SQLValue -> a) getColumnValFunc col = case col of (ResultColumnDescription (ColDesc _ _ _ f) _ _) -> f (Case _ (_, _) (_,f)) -> f --selector: returns the SQLType of the ColumnSingleCollection -- inside of SingleColumnSelect getSingleType :: SingleColumnSelect _ -> [SQLType] getSingleType (SingleCS _ col _ _) = getColumnType col --selector: returns the function to convert the SQLValue to the resulttype getSingleValFunc :: SingleColumnSelect a -> (SQLValue -> a) getSingleValFunc (SingleCS _ col _ _) = getColumnValFunc col --selector: returns the list of SQLTypes used -- inside the TupleColumnSelect getTupleTypes :: TupleColumnSelect _ _ -> [SQLType] getTupleTypes (TupleCS _ (col1,col2) _ _) = getColumnType col1 ++ getColumnType col2 --selector: returns the tuple of functions to convert the SQLValue --to the resulttype getTupleValFuncs :: TupleColumnSelect a b -> ((SQLValue -> a), (SQLValue -> b)) getTupleValFuncs (TupleCS _ (col1,col2) _ _) = (getColumnValFunc col1, getColumnValFunc col2) --selector: returns the list of SQLTypes used -- inside the TripleColumnSelect getTripleTypes :: TripleColumnSelect _ _ _ -> [SQLType] getTripleTypes (TripleCS _ (col1, col2, col3) _ _) = getColumnType col1 ++ getColumnType col2 ++ getColumnType col3 --selector: returns the triple of functions to convert the SQLValue --to the resulttype getTripleValFuncs :: TripleColumnSelect a b c -> ((SQLValue -> a), (SQLValue -> b), (SQLValue -> c)) getTripleValFuncs (TripleCS _ (col1, col2, col3) _ _) = (getColumnValFunc col1, getColumnValFunc col2, getColumnValFunc col3) --selector: returns the list of SQLTypes used -- inside the FourColumnSelect getFourTupleTypes :: FourColumnSelect _ _ _ _ -> [SQLType] getFourTupleTypes (FourCS _ (col1, col2, col3, col4) _ _) = getColumnType col1 ++ getColumnType col2 ++ getColumnType col3 ++ getColumnType col4 --selector: returns the fourtuple of functions to convert the --SQLValue to the resulttype getFourTupleValFuncs :: FourColumnSelect a b c d -> ((SQLValue -> a), (SQLValue -> b), (SQLValue -> c), (SQLValue -> d)) getFourTupleValFuncs (FourCS _ (col1, col2, col3, col4) _ _) = (getColumnValFunc col1, getColumnValFunc col2, getColumnValFunc col3, getColumnValFunc col4) --selector: returns the list of SQLTypes used -- inside the FiveColumnSelect getFiveTupleTypes :: FiveColumnSelect a b c d e -> [SQLType] getFiveTupleTypes (FiveCS _ (col1, col2, col3, col4, col5) _ _) = getColumnType col1 ++ getColumnType col2 ++ getColumnType col3 ++ getColumnType col4 ++ getColumnType col5 --selector: returns the fivetuple of functions to convert the --SQLValue to the resulttype getFiveTupleValFuncs :: FiveColumnSelect a b c d e -> ((SQLValue -> a), (SQLValue -> b), (SQLValue -> c), (SQLValue -> d), (SQLValue -> e)) getFiveTupleValFuncs (FiveCS _ (col1, col2, col3, col4, col5) _ _) = (getColumnValFunc col1, getColumnValFunc col2, getColumnValFunc col3, getColumnValFunc col4, getColumnValFunc col5) -- ------------------------------------------------------------------------------ -- translation functions -- ------------------------------------------------------------------------------ -- Transform a SingleColumnSelect to its string representation. trSingleSelectQuery :: SingleColumnSelect _ -> String trSingleSelectQuery (SingleCS sp col tabs crit) = ("select "++ trSpecifier sp ++ getResultColumnString col ++" from " ++ (getTableString tabs "") ++ " " ++ trCriteria crit) -- Transform a TupleColumnSelect to its string representation. trTupleSelectQuery :: TupleColumnSelect _ _ -> String trTupleSelectQuery (TupleCS sp (col1, col2) tabs crit) = ("select " ++trSpecifier sp ++ getResultColumnString col1 ++ ", "++ getResultColumnString col2 ++" from " ++ (getTableString tabs "") ++ trCriteria crit ) -- Transform a TripleColumnSelect to its string representation. trTripleSelectQuery :: TripleColumnSelect _ _ _ -> String trTripleSelectQuery (TripleCS sp (col1, col2, col3) tabs crit) = ("select " ++trSpecifier sp ++ getResultColumnString col1 ++ ", "++ getResultColumnString col2 ++ ", "++ getResultColumnString col3 ++ " from " ++ (getTableString tabs "") ++ trCriteria crit ) -- Transform a FourTupleColumnSelect to its string representation. trFourTupleSelectQuery :: FourColumnSelect _ _ _ _ -> String trFourTupleSelectQuery (FourCS sp (col1, col2, col3, col4) tabs crit) = ("select " ++trSpecifier sp ++ getResultColumnString col1 ++ ", "++ getResultColumnString col2 ++ ", "++ getResultColumnString col3 ++ ", "++ getResultColumnString col4 ++ " from " ++ (getTableString tabs "") ++ trCriteria crit ) -- Transform a FiveTupleColumnSelect to its string representation. trFiveTupleSelectQuery :: FiveColumnSelect _ _ _ _ _ -> String trFiveTupleSelectQuery (FiveCS sp (col1, col2, col3, col4, col5) tabs crit) = ("select " ++trSpecifier sp ++ getResultColumnString col1 ++ ", "++ getResultColumnString col2 ++", "++ getResultColumnString col3 ++", "++ getResultColumnString col4 ++ ", "++ getResultColumnString col5 ++" from " ++ (getTableString tabs "") ++ trCriteria crit ) -- translate set operations trSetOp :: SetOp -> String trSetOp Union = " union " trSetOp Intersect = " intersect " trSetOp Except = " except " -- translate limit clause trLimit :: Maybe Int -> String trLimit limit = case limit of Nothing -> "" Just n -> " Limit "++(show n) -- Create the "as tablename" string asTable :: Table -> Int -> Table asTable table n = case n of 0 -> "" m -> " as '" ++ (show m) ++ table ++ "'" -- translate joins trJoinPart1 :: Join -> String trJoinPart1 Cross = " cross join" trJoinPart1 (Inner _) = " inner join" trJoinPart2 :: Join -> String trJoinPart2 Cross = "" trJoinPart2 (Inner constraint) = " ON (" ++ (trConstraint constraint)++")" -- translate a ColumnSingleCollection getResultColumnString:: ColumnSingleCollection a -> String getResultColumnString (ResultColumnDescription (ColDesc name _ _ _) alias aggr) = aggr ++ (trColumn name alias) ++ ")" getResultColumnString (Case con (val1, val2) _ ) = "( case when " ++ trCondition con ++ " then " ++ trValue val1 ++ " else " ++ trValue val2 ++ " end)" -- translate a table-clause getTableString :: TableClause -> String -> String getTableString (TC tab alias Nothing) join2 = (" '" ++tab ++ "'" ++ (asTable tab alias)++" "++join2) getTableString (TC tab alias (Just (join, tc))) join2 = (" '" ++tab ++ "'" ++ (asTable tab alias)++join2 ++(trJoinPart1 join) ++ (getTableString tc (trJoinPart2 join))) getCharValue :: SQLValue -> Char getCharValue (SQLChar char) = char getDateValue :: SQLValue -> Time.ClockTime getDateValue (SQLDate date) = date getFloatValue :: SQLValue -> Float getFloatValue (SQLFloat float) = float getIntValue :: SQLValue -> Int getIntValue (SQLInt int) = int getStringValue :: SQLValue -> String getStringValue (SQLString str) = str getBoolValue :: SQLValue -> Bool getBoolValue (SQLBool bool) = bool curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Database/ERD.curry000066400000000000000000000117341305333611600244420ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This module contains the definition of data types to represent --- entity/relationship diagrams and an I/O operation to read them --- from a term file. --- --- @author Michael Hanus, Marion Mueller --- @version June 2016 --- @category database ------------------------------------------------------------------------------ module Database.ERD ( ERD(..), ERDName, Entity(..), EName, Entity(..) , Attribute(..), AName, Key(..), Null, Domain(..) , Relationship(..), REnd(..), RName, Role, Cardinality(..), MaxValue(..) , readERDTermFile ) where import Char(isSpace) import IO import ReadShowTerm(readUnqualifiedTerm) import Time --- Data type to represent entity/relationship diagrams. data ERD = ERD ERDName [Entity] [Relationship] type ERDName = String -- used as the name of the generated module data Entity = Entity EName [Attribute] type EName = String data Attribute = Attribute AName Domain Key Null type AName = String data Key = NoKey | PKey | Unique type Null = Bool data Domain = IntDom (Maybe Int) | FloatDom (Maybe Float) | CharDom (Maybe Char) | StringDom (Maybe String) | BoolDom (Maybe Bool) | DateDom (Maybe CalendarTime) | UserDefined String (Maybe String) | KeyDom String -- for foreign keys data Relationship = Relationship RName [REnd] type RName = String data REnd = REnd EName Role Cardinality type Role = String --- Cardinality of a relationship w.r.t. some entity. --- The cardinality is either a fixed number (e.g., (Exactly 1) --- representing the cardinality (1,1)) --- or an interval (e.g., (Between 1 (Max 4)) representing the --- cardinality (1,4), or (Between 0 Infinite) representing the --- cardinality (0,n)). data Cardinality = Exactly Int | Between Int MaxValue --- The upper bound of a cardinality which is either a finite number --- or infinite. data MaxValue = Max Int | Infinite --- Read an ERD specification from a file containing a single ERD term. readERDTermFile :: String -> IO ERD readERDTermFile termfilename = do putStrLn $ "Reading ERD term from file " ++ termfilename ++ "..." handle <- openFile termfilename ReadMode line <- skipCommentLines handle termstring <- hGetContents handle return (updateERDTerm (readUnqualifiedTerm ["Database.ERD","Prelude"] (unlines [line,termstring]))) where skipCommentLines h = do line <- hGetLine h >>= return . dropWhile isSpace if null line || take 2 line == "--" then skipCommentLines h else if take 2 line == "{-" -- -} then skipBracketComment h (drop 2 line) else return line skipBracketComment h [] = hGetLine h >>= skipBracketComment h skipBracketComment h [_] = hGetLine h >>= skipBracketComment h skipBracketComment h (c1:c2:cs) = if c1=='-' && c2=='}' then return cs else skipBracketComment h (c2:cs) --- Transforms an ERD term possible containing old, outdated, information. --- In particular, translate (Range ...) into (Between ...). updateERDTerm :: ERD -> ERD updateERDTerm (ERD name es rs) = ERD name es (map updateRel rs) where updateRel (Relationship r ends) = Relationship r (map updateEnd ends) updateEnd (REnd n r c) = REnd n r (updateCard c) updateCard (Exactly n) = Exactly n updateCard (Between min (Max m)) = if min<=m then Between min (Max m) else error ("ERD: Illegal cardinality " ++ show (Between min (Max m))) updateCard (Between min Infinite) = Between min Infinite {- -- Example ERD term: (ERD "Uni" [Entity "Student" [Attribute "MatNum" (IntDom Nothing) PKey False, Attribute "Name" (StringDom Nothing) NoKey False, Attribute "Firstname" (StringDom Nothing) NoKey False, Attribute "Email" (UserDefined "MyModule.Email" Nothing) NoKey True], Entity "Lecture" [Attribute "Id" (IntDom Nothing) PKey False, Attribute "Title" (StringDom Nothing) Unique False, Attribute "Hours" (IntDom (Just 4)) NoKey False], Entity "Lecturer" [Attribute "Id" (IntDom Nothing) PKey False, Attribute "Name" (StringDom Nothing) NoKey False, Attribute "Firstname" (StringDom Nothing) NoKey False], Entity "Group" [Attribute "Time" (StringDom Nothing) NoKey False]] [Relationship "Teaching" [REnd "Lecturer" "taught_by" (Exactly 1), REnd "Lecture" "teaches" (Between 0 Infinite)], Relationship "Participation" [REnd "Student" "participated_by" (Between 0 Infinite), REnd "Lecture" "participates" (Between 0 Infinite)], Relationship "Membership" [REnd "Student" "consists_of" (Exactly 3), REnd "Group" "member_of" (Between 0 Infinite)]]) -} curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Database/ERDGoodies.curry000066400000000000000000000145771305333611600257640ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This module contains some useful operations on the data types representing --- entity/relationship diagrams --- --- @author Michael Hanus --- @version October 2016 --- @category database ------------------------------------------------------------------------------ module Database.ERDGoodies ( erdName, entityName, isEntityNamed, entityAttributes , hasForeignKey, foreignKeyAttributes , attributeName, attributeDomain, hasDefault , isForeignKey, isNullAttribute , cardMinimum, cardMaximum , showERD, combineIds , storeERDFromProgram, writeERDTermFile ) where import Char(isUpper) import Database.ERD import Distribution(installDir,stripCurrySuffix) import FlatCurry.Types import FlatCurry.Files import FlatCurry.Goodies import IOExts (evalCmd) import List(intersperse) import Maybe import System(system) --- The name of an ERD. erdName :: ERD -> String erdName (ERD name _ _) = name --- The name of an entity. entityName :: Entity -> String entityName (Entity n _) = n --- Is this an entity with a given name? isEntityNamed :: String -> Entity -> Bool isEntityNamed n e = entityName e == n --- Has the entity an attribute with a foreign key for a given entity name? hasForeignKey :: String -> Entity -> Bool hasForeignKey ename (Entity _ attrs) = any isForeignKeyWithName attrs where isForeignKeyWithName (Attribute _ d _ _) = case d of KeyDom n -> n==ename _ -> False --- Returns the attributes that are a foreign key of a given entity name. foreignKeyAttributes :: String -> [Attribute] -> [Attribute] foreignKeyAttributes ename attrs = filter isForeignKeyWithName attrs where isForeignKeyWithName (Attribute _ d _ _) = case d of KeyDom n -> n==ename _ -> False --- Returns the names of the foreign key attributes for a given entity name. foreignKeyAttrNames :: String -> [Attribute] -> [String] foreignKeyAttrNames ename attrs = map attributeName (filter isForeignKeyWithName attrs) where isForeignKeyWithName (Attribute _ d _ _) = case d of KeyDom n -> n==ename _ -> False --- The attributes of an entity entityAttributes :: Entity -> [Attribute] entityAttributes (Entity _ attrs) = attrs --- The name of an attribute. attributeName :: Attribute -> String attributeName (Attribute name _ _ _) = name --- The domain of an attribute. attributeDomain :: Attribute -> Domain attributeDomain (Attribute _ d _ _) = d --- Has an attribute domain a default value? hasDefault :: Domain -> Bool hasDefault (IntDom d) = isJust d hasDefault (FloatDom d) = isJust d hasDefault (StringDom d) = isJust d hasDefault (BoolDom d) = isJust d hasDefault (DateDom d) = isJust d hasDefault (UserDefined _ d) = isJust d ---- Is an attribute a (generated) foreign key? isForeignKey :: Attribute -> Bool isForeignKey (Attribute _ d _ _) = case d of KeyDom _ -> True _ -> False --- Has an attribute a null value? isNullAttribute :: Attribute -> Bool isNullAttribute (Attribute _ _ _ isnull) = isnull --- The minimum value of a cardinality. cardMinimum :: Cardinality -> Int cardMinimum (Exactly i) = i cardMinimum (Between i _) = i --- The maximum value of a cardinality (provided that it is not infinite). cardMaximum :: Cardinality -> Int cardMaximum (Exactly i) = i cardMaximum (Between _ (Max i)) = i --- A simple pretty printer for ERDs. showERD :: Int -> ERD -> String showERD n (ERD en es rs) = "ERD " ++ showString en ++ lb n ++ " [" ++ concat (intersperse ("," ++ lb (n+2)) (map (showEs (n+2)) es)) ++ "]" ++ lb n ++ " [" ++ concat (intersperse ("," ++ lb (n+2)) (map (showRs (n+2)) rs)) ++ "]" showEs n (Entity en attrs) = "Entity " ++ showString en ++ lb (n+7) ++ "[" ++ concat (intersperse ("," ++ lb (n+8)) (map showWOBrackets attrs)) ++"]" showRs n (Relationship rn ends) = "Relationship " ++ showString rn ++ lb (n+13) ++ "[" ++ concat (intersperse ("," ++ lb (n+14)) (map showWOBrackets ends)) ++"]" showWOBrackets t = stripBrackets (show t) where stripBrackets (c:cs) = if c=='(' then reverse (tail (reverse cs)) else c:cs showString s = "\""++s++"\"" lb n = "\n" ++ take n (repeat ' ') --- Combines a non-empty list of identifiers into a single identifier. --- Used in ERD transformation and code generation to create --- names for combined objects, e.g., relationships and foreign keys. combineIds :: [String] -> String combineIds (name:names) = name ++ concatMap maybeAddUnderscore names where maybeAddUnderscore [] = "_" maybeAddUnderscore s@(c:_) = if isUpper c then s else '_' : s ------------------------------------------------------------------------------ -- Auxiliaries to generate ERD term file from a ERD definition given -- in a Curry program. --- Writes the ERD defined in a Curry program (as a top-level operation --- of type `Database.ERD.ERD`) in a term file and return the name of --- the term file. storeERDFromProgram :: String -> IO String storeERDFromProgram progfile = do putStrLn $ "Creating ERD term file from program `" ++ progfile ++ "'..." let progname = stripCurrySuffix progfile prog <- readFlatCurry progname let funcs = progFuncs prog erdfuncs = filter hasERDType funcs case erdfuncs of [] -> error $ "No definition of ER model found in program " ++ progfile [fd] -> do let cmd = installDir++"/bin/curry" args = [":set","v0",":load",progname ,":add","Database.ERDGoodies" ,":eval","writeERDTermFile "++snd (funcName fd) ,":quit"] (ecode,outstr,errstr) <- evalCmd cmd args "" if ecode > 0 then error $ "ERROR in ERD term file generation:\n" ++ errstr else return (head (lines outstr)) _ -> error $ "Multiple ER model definitions found in program " ++ progfile hasERDType fdecl = funcType fdecl == TCons ("Database.ERD","ERD") [] --- Writes an ERD term into a file with name `ERDMODELNAME.erdterm` --- and prints the name of the generated file. writeERDTermFile :: ERD -> IO () writeERDTermFile erd = do let termfile = erdName erd ++ ".erdterm" writeFile termfile (showERD 0 erd) putStrLn termfile ------------------------------------------------------------------------------ curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Debug.curry000066400000000000000000000031331305333611600233440ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library contains some useful operation for debugging programs. --- --- @author Bjoern Peemoeller --- @version September 2014 --- @category general ------------------------------------------------------------------------------ module Debug ( trace, traceId, traceShow, traceShowId, traceIO , assert, assertIO ) where import IO (hPutStrLn, stderr) import Unsafe (unsafePerformIO) --- Prints the first argument as a side effect and behaves as identity on the --- second argument. trace :: String -> a -> a trace s x = unsafePerformIO (traceIO s >> return x) --- Prints the first argument as a side effect and returns it afterwards. traceId :: String -> String traceId a = trace a a --- Prints the first argument using `show` and returns the second argument --- afterwards. traceShow :: a -> b -> b traceShow a b = trace (show a) b --- Prints the first argument using `show` and returns it afterwards. traceShowId :: a -> a traceShowId a = trace (show a) a --- Output a trace message from the `IO` monad. traceIO :: String -> IO () traceIO m = hPutStrLn stderr m --- Assert a condition w.r.t. an error message. --- If the condition is not met it fails with the given error message, --- otherwise the third argument is returned. assert :: Bool -> String -> a -> a assert cond s x = if cond then x else error s --- Assert a condition w.r.t. an error message from the `IO` monad. --- If the condition is not met it fails with the given error message. assertIO :: Bool -> String -> IO () assertIO cond s = unless cond $ error s curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Dequeue.curry000066400000000000000000000074721305333611600237250ustar00rootroot00000000000000------------------------------------------------------------------------------ --- An implementation of double-ended queues supporting access at both --- ends in constant amortized time. --- --- @author Bernd Brassel, Olaf Chitil, Michael Hanus, Sebastian Fischer, --- Bjoern Peemoeller --- @version January 2015 --- @category algorithm ------------------------------------------------------------------------------ module Dequeue ( -- Abstract data type, constructors and queries Queue, empty, cons, snoc, isEmpty, deqLength -- Selectors , deqHead, deqTail, deqLast, deqInit, deqReverse, rotate, matchHead, matchLast -- conversion from and to lists , listToDeq, deqToList ) where --- The datatype of a queue. data Queue a = S Int [a] Int [a] --- The empty queue. empty :: Queue _ empty = S 0 [] 0 [] --- Inserts an element at the front of the queue. cons :: a -> Queue a -> Queue a cons x (S lenf f lenr r) = check (lenf + 1) (x : f) lenr r --- Inserts an element at the end of the queue. snoc :: a -> Queue a -> Queue a snoc x (S lenf f lenr r) = deqReverse (check (lenr + 1) (x : r) lenf f) --- Is the queue empty? isEmpty :: Queue _ -> Bool isEmpty (S lenf _ lenr _) = lenf + lenr == 0 --- Returns the number of elements in the queue. deqLength :: Queue _ -> Int deqLength (S lenf _ lenr _) = lenf + lenr --- The first element of the queue. deqHead :: Queue a -> a deqHead (S lenf f _ r) = head (if lenf == 0 then r else f) --- Removes an element at the front of the queue. deqTail :: Queue a -> Queue a deqTail (S _ [] _ _) = empty deqTail (S lenf (_:fs) lenr r) = deqReverse (check lenr r (lenf - 1) fs) --- The last element of the queue. deqLast :: Queue a -> a deqLast (S _ f lenr r) = head (if lenr == 0 then f else r) --- Removes an element at the end of the queue. deqInit :: Queue a -> Queue a deqInit (S _ _ _ [] ) = empty deqInit (S lenf f lenr (_:rs)) = check lenf f (lenr - 1) rs --- Reverses a double ended queue. deqReverse :: Queue a -> Queue a deqReverse (S lenf f lenr r) = S lenr r lenf f --- Moves the first element to the end of the queue. rotate :: Queue a -> Queue a rotate q = snoc (deqHead q) (deqTail q) --- Matches the front of a queue. --- matchHead q is equivalent to --- if isEmpty q then Nothing else Just (deqHead q, deqTail q) --- but more efficient. matchHead :: Queue a -> Maybe (a, Queue a) matchHead (S _ [] _ [] ) = Nothing matchHead (S _ [] _ [x] ) = Just (x, empty) matchHead q@(S _ [] _ (_:_:_)) = error $ "Dequeue.matchHead: illegal queue " ++ show q matchHead (S lenf (x:xs) lenr r ) = Just (x, deqReverse (check lenr r (lenf - 1) xs)) --- Matches the end of a queue. --- matchLast q is equivalent to --- if isEmpty q then Nothing else Just (deqLast q,deqInit q) --- but more efficient. matchLast :: Queue a -> Maybe (a,Queue a) matchLast (S _ [] _ [] ) = Nothing matchLast (S _ [x] _ [] ) = Just (x, empty) matchLast q@(S _ (_:_:_) _ [] ) = error $ "Dequeue.matchLast: illegal queue " ++ show q matchLast (S lenf f lenr (x:xs)) = Just (x, check lenf f (lenr - 1) xs) --- Transforms a list to a double ended queue. listToDeq :: [a] -> Queue a listToDeq xs = check (length xs) xs 0 [] --- Transforms a double ended queue to a list. deqToList :: Queue a -> [a] deqToList (S _ xs _ ys) = xs ++ reverse ys --- Check for invariant: The length of the first list is smaller than --- three times the length of the second plus 1. check :: Int -> [a] -> Int -> [a] -> Queue a check lenf f lenr r | lenf <= 3 * lenr + 1 = S lenf f lenr r | otherwise = S lenf' f' lenr' r' where len = lenf + lenr lenf' = len `div` 2 lenr' = len - lenf' (f', rf') = splitAt lenf' f r' = r ++ reverse rf' curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Directory.curry000066400000000000000000000114231305333611600242630ustar00rootroot00000000000000--- Library for accessing the directory structure of the --- underlying operating system. --- --- @author Michael Hanus --- @version January 2013 --- @category general module Directory ( doesFileExist, doesDirectoryExist, fileSize, getModificationTime , getCurrentDirectory, setCurrentDirectory , getDirectoryContents, createDirectory, createDirectoryIfMissing , removeDirectory, renameDirectory , getHomeDirectory, getTemporaryDirectory , getAbsolutePath , removeFile, renameFile, copyFile ) where import FilePath (FilePath, (), splitDirectories, isAbsolute, normalise) import List (isPrefixOf, scanl1, last) import System (getEnviron, isWindows) import Time (ClockTime) --- Returns true if the argument is the name of an existing file. doesFileExist :: FilePath -> IO Bool doesFileExist fname = prim_doesFileExist $## fname prim_doesFileExist :: FilePath -> IO Bool prim_doesFileExist external --- Returns true if the argument is the name of an existing directory. doesDirectoryExist :: FilePath -> IO Bool doesDirectoryExist dir = prim_doesDirectoryExist $## dir prim_doesDirectoryExist :: FilePath -> IO Bool prim_doesDirectoryExist external --- Returns the size of the file. fileSize :: FilePath -> IO Int fileSize fname = prim_fileSize $## fname prim_fileSize :: FilePath -> IO Int prim_fileSize external --- Returns the modification time of the file. getModificationTime :: FilePath -> IO ClockTime getModificationTime fname = prim_getModificationTime $## fname prim_getModificationTime :: FilePath -> IO ClockTime prim_getModificationTime external --- Returns the current working directory. getCurrentDirectory :: IO FilePath getCurrentDirectory external --- Sets the current working directory. setCurrentDirectory :: FilePath -> IO () setCurrentDirectory dir = prim_setCurrentDirectory $## dir prim_setCurrentDirectory :: FilePath -> IO () prim_setCurrentDirectory external --- Returns the list of all entries in a directory. getDirectoryContents :: FilePath -> IO [FilePath] getDirectoryContents dir = prim_getDirectoryContents $## dir prim_getDirectoryContents :: FilePath -> IO [FilePath] prim_getDirectoryContents external --- Creates a new directory with the given name. createDirectory :: FilePath -> IO () createDirectory dir = prim_createDirectory $## dir prim_createDirectory :: FilePath -> IO () prim_createDirectory external --- Creates a new directory with the given name if it does not already exist. --- If the first parameter is `True` it will also create all missing --- parent directories. createDirectoryIfMissing :: Bool -> FilePath -> IO () createDirectoryIfMissing createParents path = if createParents then createDirs parents else createDirs [last parents] where parents = scanl1 () $ splitDirectories $ path createDirs [] = done createDirs (d:ds) = do exists <- doesDirectoryExist d if exists then done else createDirectory d createDirs ds --- Deletes a directory from the file system. removeDirectory :: FilePath -> IO () removeDirectory dir = prim_removeDirectory $## dir prim_removeDirectory :: FilePath -> IO () prim_removeDirectory external --- Renames a directory. renameDirectory :: FilePath -> FilePath -> IO () renameDirectory dir1 dir2 = (prim_renameDirectory $## dir1) $## dir2 prim_renameDirectory :: FilePath -> FilePath -> IO () prim_renameDirectory external --- Returns the home directory of the current user. getHomeDirectory :: IO FilePath getHomeDirectory = if isWindows then getEnviron "USERPROFILE" else getEnviron "HOME" --- Returns the temporary directory of the operating system. getTemporaryDirectory :: IO FilePath getTemporaryDirectory = if isWindows then getEnviron "TMP" else return "/tmp" --- Convert a path name into an absolute one. --- For instance, a leading `~` is replaced by the current home directory. getAbsolutePath :: FilePath -> IO FilePath getAbsolutePath path | isAbsolute path = return (normalise path) | path == "~" = getHomeDirectory | "~/" `isPrefixOf` path = do homedir <- getHomeDirectory return (normalise (homedir drop 2 path)) | otherwise = do curdir <- getCurrentDirectory return (normalise (curdir path)) --- Deletes a file from the file system. removeFile :: FilePath -> IO () removeFile file = prim_removeFile $## file prim_removeFile :: FilePath -> IO () prim_removeFile external --- Renames a file. renameFile :: FilePath -> FilePath -> IO () renameFile file1 file2 = (prim_renameFile $## file1) $## file2 prim_renameFile :: FilePath -> FilePath -> IO () prim_renameFile external --- Copy the contents from one file to another file copyFile :: FilePath -> FilePath -> IO () copyFile src dest = readFile src >>= writeFile dest curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Directory.prim_c2p000066400000000000000000000034311305333611600246320ustar00rootroot00000000000000 prim_directory prim_doesFileExist prim_directory prim_doesDirectoryExist prim_directory prim_fileSize prim_directory prim_getModificationTime prim_directory prim_getDirectoryContents prim_directory prim_getCurrentDirectory prim_directory prim_setCurrentDirectory prim_directory prim_createDirectory prim_directory prim_removeFile prim_directory prim_removeDirectory prim_directory prim_renameFile prim_directory prim_renameDirectory curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Distribution.curry000066400000000000000000000436501305333611600250050ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- This module contains functions to obtain information concerning the current --- distribution of the Curry implementation, e.g., --- compiler version, load paths, front end. --- --- @author Bernd Brassel, Michael Hanus, Bjoern Peemoeller --- @version December 2016 --- @category general -------------------------------------------------------------------------------- module Distribution ( curryCompiler,curryCompilerMajorVersion,curryCompilerMinorVersion, curryRuntime,curryRuntimeMajorVersion,curryRuntimeMinorVersion, installDir,stripCurrySuffix,modNameToPath, currySubdir,inCurrySubdir,addCurrySubdir, rcFileName,rcFileContents,getRcVar,getRcVars, joinModuleIdentifiers, splitModuleIdentifiers, splitModuleFileName, inCurrySubdirModule, sysLibPath, getLoadPathForModule, lookupModuleSourceInLoadPath, lookupModuleSource, FrontendTarget(..), FrontendParams, defaultParams, rcParams, quiet, extended, overlapWarn, fullPath, htmldir, logfile, specials, setQuiet, setExtended, setOverlapWarn, setFullPath, setHtmlDir, setLogfile, addTarget, setSpecials, callFrontend,callFrontendWithParams ) where import List (nub, split) import Char (toLower) import Directory (doesFileExist, getHomeDirectory) import FileGoodies (lookupFileInPath, getFileInPath, fileSuffix, stripSuffix) import FilePath ( FilePath, (), (<.>), addTrailingPathSeparator , dropFileName, joinPath, normalise, splitDirectories , splitExtension, splitFileName, splitSearchPath , takeFileName ) import IO import PropertyFile import System ----------------------------------------------------------------- -- Compiler and run-time environment name and version ----------------------------------------------------------------- -- if you do not use other functions but -- if-then-else, and the _Prelude_ functions -- (<), (>), (<=), (>=), (==) -- directly on the following constants, -- the compiler might be able to eliminate -- them at compile time. --- The name of the Curry compiler (e.g., "pakcs" or "kics2"). curryCompiler :: String curryCompiler external --- The major version number of the Curry compiler. curryCompilerMajorVersion :: Int curryCompilerMajorVersion external --- The minor version number of the Curry compiler. curryCompilerMinorVersion :: Int curryCompilerMinorVersion external --- The name of the run-time environment (e.g., "sicstus", "swi", or "ghc") curryRuntime :: String curryRuntime external --- The major version number of the Curry run-time environment. curryRuntimeMajorVersion :: Int curryRuntimeMajorVersion external --- The minor version number of the Curry run-time environment. curryRuntimeMinorVersion :: Int curryRuntimeMinorVersion external --- Path of the main installation directory of the Curry compiler. installDir :: FilePath installDir external --------------------------------------------------- -- retrieving user specified options from rc file --------------------------------------------------- --- The name of the file specifying configuration parameters of the --- current distribution. This file must have the usual format of --- property files (see description in module PropertyFile). rcFileName :: IO String rcFileName = getHomeDirectory >>= return . ( rcFile) where rcFile = '.' : curryCompiler ++ "rc" --- Returns the current configuration parameters of the distribution. --- This action yields the list of pairs (var,val). rcFileContents :: IO [(String,String)] rcFileContents = rcFileName >>= readPropertyFile --- Look up a specific configuration variable as specified by user in his rc file. --- Uppercase/lowercase is ignored for the variable names. getRcVar :: String -> IO (Maybe String) getRcVar var = getRcVars [var] >>= return . head --- Look up configuration variables as specified by user in his rc file. --- Uppercase/lowercase is ignored for the variable names. getRcVars :: [String] -> IO [Maybe String] getRcVars vars = do rcs <- rcFileContents return (map (flip lookup (map (\ (a, b) -> (map toLower a, b)) rcs)) (map (map toLower) vars)) ----------------------------------------------------------- --- Functions for handling file names of Curry modules ----------------------------------------------------------- type ModuleIdent = String --- Split the `FilePath` of a module into the directory prefix and the --- `FilePath` corresponding to the module name. --- For instance, the call `splitModuleFileName "Data.Set" "lib/Data/Set.curry"` --- evaluates to `("lib", "Data/Set.curry")`. --- This can be useful to compute output directories while retaining the --- hierarchical module structure. splitModuleFileName :: ModuleIdent -> FilePath -> (FilePath, FilePath) splitModuleFileName mid fn = case splitModuleIdentifiers mid of [_] -> splitFileName fn ms -> let (base, ext) = splitExtension fn dirs = splitDirectories base (pre , suf) = splitAt (length dirs - length ms) dirs path = if null pre then "" else addTrailingPathSeparator (joinPath pre) in (path, joinPath suf <.> ext) --- Split up the components of a module identifier. For instance, --- `splitModuleIdentifiers "Data.Set"` evaluates to `["Data", "Set"]`. splitModuleIdentifiers :: ModuleIdent -> [String] splitModuleIdentifiers = split (=='.') --- Join the components of a module identifier. For instance, --- `joinModuleIdentifiers ["Data", "Set"]` evaluates to `"Data.Set"`. joinModuleIdentifiers :: [String] -> ModuleIdent joinModuleIdentifiers = foldr1 combine where combine xs ys = xs ++ '.' : ys --- Strips the suffix ".curry" or ".lcurry" from a file name. stripCurrySuffix :: String -> String stripCurrySuffix s = if fileSuffix s `elem` ["curry","lcurry"] then stripSuffix s else s --- A module path consists of a directory prefix (which can be omitted) --- and a module name (which can be hierarchical). For instance, the --- following strings are module paths in Unix-based systems: --- --- HTML --- Data.Number.Int --- curry/Data.Number.Int type ModulePath = String --- Transforms a hierarchical module name into a path name, i.e., --- replace the dots in the name by directory separator chars. modNameToPath :: ModuleIdent -> String modNameToPath = foldr1 () . split (=='.') --- Name of the sub directory where auxiliary files (.fint, .fcy, etc) --- are stored. currySubdir :: FilePath currySubdir = ".curry" --- Transforms a path to a module name into a file name --- by adding the `currySubDir` to the path and transforming --- a hierarchical module name into a path. --- For instance, `inCurrySubdir "mylib/Data.Char"` evaluates to --- `"mylib/.curry/Data/Char"`. inCurrySubdir :: FilePath -> FilePath inCurrySubdir filename = let (base,file) = splitFileName filename in base currySubdir modNameToPath file --- Transforms a file name by adding the currySubDir to the file name. --- This version respects hierarchical module names. inCurrySubdirModule :: ModuleIdent -> FilePath -> FilePath inCurrySubdirModule m fn = let (dirP, modP) = splitModuleFileName m fn in dirP currySubdir modP --- Transforms a directory name into the name of the corresponding --- sub directory containing auxiliary files. addCurrySubdir :: FilePath -> FilePath addCurrySubdir dir = dir currySubdir ----------------------------------------------------------- --- finding files in correspondence to compiler load path ----------------------------------------------------------- --- Returns the current path (list of directory names) of the --- system libraries. sysLibPath :: [String] sysLibPath = case curryCompiler of "pakcs" -> [installDir "lib"] "kics" -> [installDir "src" "lib"] "kics2" -> [installDir "lib"] _ -> error "Distribution.sysLibPath: unknown curryCompiler" --- Returns the current path (list of directory names) that is --- used for loading modules w.r.t. a given module path. --- The directory prefix of the module path (or "." if there is --- no such prefix) is the first element of the load path and the --- remaining elements are determined by the environment variable --- CURRYRPATH and the entry "libraries" of the system's rc file. getLoadPathForModule :: ModulePath -> IO [String] getLoadPathForModule modpath = do mblib <- getRcVar "libraries" let fileDir = dropFileName modpath if curryCompiler `elem` ["pakcs","kics","kics2"] then do currypath <- getEnviron "CURRYPATH" let llib = maybe [] (\l -> if null l then [] else splitSearchPath l) mblib return $ (fileDir : (if null currypath then [] else splitSearchPath currypath) ++ llib ++ sysLibPath) else error "Distribution.getLoadPathForModule: unknown curryCompiler" --- Returns a directory name and the actual source file name for a module --- by looking up the module source in the current load path. --- If the module is hierarchical, the directory is the top directory --- of the hierarchy. --- Returns Nothing if there is no corresponding source file. lookupModuleSourceInLoadPath :: ModulePath -> IO (Maybe (String,String)) lookupModuleSourceInLoadPath modpath = do loadpath <- getLoadPathForModule modpath lookupModuleSource loadpath modpath --- Returns a directory name and the actual source file name for a module --- by looking up the module source in the load path provided as the --- first argument. --- If the module is hierarchical, the directory is the top directory --- of the hierarchy. --- Returns Nothing if there is no corresponding source file. lookupModuleSource :: [String] -> String -> IO (Maybe (String,String)) lookupModuleSource loadpath mod = lookupSourceInPath loadpath where fn = takeFileName mod fnlcurry = modNameToPath fn ++ ".lcurry" fncurry = modNameToPath fn ++ ".curry" lookupSourceInPath [] = return Nothing lookupSourceInPath (dir:dirs) = do lcurryExists <- doesFileExist (dir fnlcurry) if lcurryExists then return (Just (dir, dir fnlcurry)) else do curryExists <- doesFileExist (dir fncurry) if curryExists then return (Just (dir, dir fncurry)) else lookupSourceInPath dirs ------------------------------------------------------------------- -- calling the front end ------------------------------------------------------------------- --- Data type for representing the different target files that can be produced --- by the front end of the Curry compiler. --- @cons FCY - FlatCurry file ending with .fcy --- @cons FINT - FlatCurry interface file ending with .fint --- @cons ACY - AbstractCurry file ending with .acy --- @cons UACY - Untyped (without type checking) AbstractCurry file ending with .uacy --- @cons HTML - colored HTML representation of source program --- @cons CY - source representation employed by the frontend --- @cons TOKS - token stream of source program data FrontendTarget = FCY | FINT | ACY | UACY | HTML | CY | TOKS --- Abstract data type for representing parameters supported by the front end --- of the Curry compiler. -- The parameters are of the form -- FrontendParams Quiet Extended NoOverlapWarn FullPath HtmlDir LogFile Specials -- where -- Quiet - work silently -- Extended - support extended Curry syntax -- OverlapWarn - warn for overlapping rules -- FullPath dirs - the complete list of directory names for loading modules -- HtmlDir file - output directory (only relevant for HTML target) -- LogFile file - store all output (including errors) of the front end in file -- Targets - additional targets for the front end -- Specials - additional special parameters (use with care!) data FrontendParams = FrontendParams Bool Bool Bool (Maybe [String]) (Maybe String) (Maybe String) [FrontendTarget] String --- The default parameters of the front end. defaultParams :: FrontendParams defaultParams = FrontendParams False True True Nothing Nothing Nothing [] "" --- The default parameters of the front end as configured by the compiler --- specific resource configuration file. rcParams :: IO FrontendParams rcParams = do [mbExtended,mbOverlapWarn] <- getRcVars ["curryextensions","warnoverlapping"] return $ setExtended (mbExtended /= Just "no") $ setOverlapWarn (mbOverlapWarn /= Just "no") $ defaultParams --- Set quiet mode of the front end. setQuiet :: Bool -> FrontendParams -> FrontendParams setQuiet s (FrontendParams _ v w x y z ts sp) = FrontendParams s v w x y z ts sp --- Set extended mode of the front end. setExtended :: Bool -> FrontendParams -> FrontendParams setExtended s (FrontendParams a _ w x y z ts sp) = FrontendParams a s w x y z ts sp --- Set overlap warn mode of the front end. setOverlapWarn :: Bool -> FrontendParams -> FrontendParams setOverlapWarn s (FrontendParams a b _ x y z ts sp) = FrontendParams a b s x y z ts sp --- Set the full path of the front end. --- If this parameter is set, the front end searches all modules --- in this path (instead of using the default path). setFullPath :: [String] -> FrontendParams -> FrontendParams setFullPath s (FrontendParams a b c _ y z ts sp) = FrontendParams a b c (Just s) y z ts sp --- Set the htmldir parameter of the front end. --- Relevant for HTML generation. setHtmlDir :: String -> FrontendParams -> FrontendParams setHtmlDir s (FrontendParams a b c d _ z ts sp) = FrontendParams a b c d (Just s) z ts sp --- Set the logfile parameter of the front end. --- If this parameter is set, all messages produced by the front end --- are stored in this file. setLogfile :: String -> FrontendParams -> FrontendParams setLogfile s (FrontendParams a b c d e _ ts sp) = FrontendParams a b c d e (Just s) ts sp --- Set additional specials parameters of the front end. --- These parameters are specific for the current front end and --- should be used with care, since their form might change in the future. setSpecials :: String -> FrontendParams -> FrontendParams setSpecials sp (FrontendParams a b c d e z ts _) = FrontendParams a b c d e z ts sp --- Add an additional front end target. addTarget :: FrontendTarget -> FrontendParams -> FrontendParams addTarget t (FrontendParams a b c d e z ts sp) = FrontendParams a b c d e z (t:ts) sp --- Returns the value of the "quiet" parameter. quiet :: FrontendParams -> Bool quiet (FrontendParams x _ _ _ _ _ _ _) = x --- Returns the value of the "extended" parameter. extended :: FrontendParams -> Bool extended (FrontendParams _ x _ _ _ _ _ _) = x --- Returns the value of the "overlapWarn" parameter. overlapWarn :: FrontendParams -> Bool overlapWarn (FrontendParams _ _ x _ _ _ _ _) = x --- Returns the full path parameter of the front end. fullPath :: FrontendParams -> Maybe [String] fullPath (FrontendParams _ _ _ x _ _ _ _) = x --- Returns the htmldir parameter of the front end. htmldir :: FrontendParams -> Maybe String htmldir (FrontendParams _ _ _ _ x _ _ _) = x --- Returns the logfile parameter of the front end. logfile :: FrontendParams -> Maybe String logfile (FrontendParams _ _ _ _ _ x _ _) = x --- Returns the special parameters of the front end. specials :: FrontendParams -> String specials (FrontendParams _ _ _ _ _ _ _ x) = x --- Returns the special parameters of the front end. targets :: FrontendParams -> [FrontendTarget] targets (FrontendParams _ _ _ _ _ _ x _) = x --- In order to make sure that compiler generated files (like .fcy, .fint, .acy) --- are up to date, one can call the front end of the Curry compiler --- with this action. --- If the front end returns with an error, an exception is raised. --- @param target - the kind of target file to be generated --- @param progname - the name of the main module of the application to be compiled callFrontend :: FrontendTarget -> String -> IO () callFrontend target p = do params <- rcParams callFrontendWithParams target params p --- In order to make sure that compiler generated files (like .fcy, .fint, .acy) --- are up to date, one can call the front end of the Curry compiler --- with this action where various parameters can be set. --- If the front end returns with an error, an exception is raised. --- @param target - the kind of target file to be generated --- @param params - parameters for the front end --- @param modpath - the name of the main module possibly prefixed with a --- directory where this module resides callFrontendWithParams :: FrontendTarget -> FrontendParams -> ModulePath -> IO () callFrontendWithParams target params modpath = do parsecurry <- callParseCurry let lf = maybe "" id (logfile params) tgts = nub (target : targets params) syscall = unwords $ [parsecurry] ++ map showFrontendTarget tgts ++ [showFrontendParams, takeFileName modpath] retcode <- if null lf then system syscall else system (syscall ++ " > " ++ lf ++ " 2>&1") if retcode == 0 then done else ioError (userError "Illegal source program") where callParseCurry = do path <- maybe (getLoadPathForModule modpath) return (fullPath params) return (quote (installDir "bin" curryCompiler ++ "-frontend") ++ concatMap ((" -i" ++) . quote) path) quote s = '"' : s ++ "\"" showFrontendTarget FCY = "--flat" showFrontendTarget FINT = "--flat" showFrontendTarget ACY = "--acy" showFrontendTarget UACY = "--uacy" showFrontendTarget HTML = "--html" showFrontendTarget CY = "--parse-only" showFrontendTarget TOKS = "--tokens" showFrontendParams = unwords [ if quiet params then runQuiet else "" , if extended params then "--extended" else "" , if overlapWarn params then "" else "--no-overlap-warn" , maybe "" ("--htmldir="++) (htmldir params) , specials params ] runQuiet = "--no-verb --no-warn --no-overlap-warn" curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Distribution.prim_c2p000066400000000000000000000022171305333611600253460ustar00rootroot00000000000000 prim_distribution prim_curryCompiler prim_distribution prim_curryCompilerMajorVersion prim_distribution prim_curryCompilerMinorVersion prim_distribution prim_curryRuntime prim_distribution prim_curryRuntimeMajorVersion prim_distribution prim_curryRuntimeMinorVersion prim_distribution prim_installDir curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Dynamic.curry.pakcs000066400000000000000000000225471305333611600250140ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for dynamic predicates. --- --- This paper contains a description of the basic ideas --- behind this library. --- --- Currently, it is still experimental so that its interface might --- be slightly changed in the future. --- --- A dynamic predicate p with arguments of type --- t1,...,tn must be declared by: --- --- p :: t1 -> ... -> tn -> Dynamic
--- p = dynamic --- --- --- A dynamic predicate where all facts should be persistently stored --- in the directory DIR must be declared by: --- --- p :: t1 -> ... -> tn -> Dynamic
--- p = persistent "file:DIR" --- --- Remark: --- This library has been revised to the library Database. --- Thus, it might not be further supported in the future. --- --- @author Michael Hanus --- @version August 2011 --- @category database ------------------------------------------------------------------------------ module Dynamic(Dynamic,(<>),(|>),(|&>),dynamic,persistent, assert,retract,getKnowledge, getDynamicSolutions,getDynamicSolution,isKnown, transaction,transactionWithErrorCatch,abortTransaction) where import AllSolutions infixr 2 <> infixl 1 |>, |&> ---------------------------------------------------------------------- --- The general type of dynamic predicates. data Dynamic = Dynamic DynSpec -- a single predicate | Prod Dynamic Dynamic -- cartesian product of two dynamics | Cond Dynamic Bool -- conditional dynamic -- The behavior specification of a dynamic predicate (only internally used). data DynSpec = Temporary -- a dynamic predicate that exists only during -- a single execution of a program | Persistent -- a persistent dynamic predicate --- dynamic is only used for the declaration of --- a dynamic predicate and should not be used elsewhere. dynamic :: _ dynamic = failed --- persistent is only used for the declaration of --- a persistent dynamic predicate and should not be used elsewhere. persistent :: String -> _ persistent _ = failed ---------------------------------------------------------------------- --- Combine two dynamics. (<>) :: Dynamic -> Dynamic -> Dynamic d1 <> d2 = Prod d1 d2 --- Restrict a dynamic with a condition. (|>) :: Dynamic -> Bool -> Dynamic d |> b = Cond d b --- Restrict a dynamic with a constraint. (|&>) :: Dynamic -> Bool -> Dynamic d |&> c = d |> (c &> True) --- Asserts new facts (without free variables!) about dynamic predicates. --- Conditional dynamics are asserted only if the condition holds. assert :: Dynamic -> IO () assert (Dynamic spec) = assertFact (Dynamic spec) assert (Prod d1 d2) = assert d1 >> assert d2 assert (Cond d b) = if b then assert d else done --- Deletes facts (without free variables!) about dynamic predicates. --- Conditional dynamics are retracted only if the condition holds. --- Returns True if all facts to be retracted exist, --- otherwise False is returned. retract :: Dynamic -> IO Bool retract (Dynamic spec) = retractFact (Dynamic spec) retract (Prod d1 d2) = do b1 <- retract d1 b2 <- retract d2 return (b1&&b2) retract (Cond d b) = if b then retract d else return True --- Returns the knowledge at a particular point of time about dynamic --- predicates. If other processes made changes to persistent predicates, --- these changes are read and made visible to the currently running program. getKnowledge :: IO (Dynamic -> Bool) getKnowledge = do known <- getDynamicKnowledge return (knownAll known) where knownAll k (Dynamic spec) = k (Dynamic spec) knownAll k (Prod d1 d2) = knownAll k d1 & knownAll k d2 knownAll k (Cond d b) = knownAll k d & b=:=True --- Returns all answers to an abstraction on a dynamic expression. --- If other processes made changes to persistent predicates, --- these changes are read and made visible to the currently running program. getDynamicSolutions :: (a -> Dynamic) -> IO [a] getDynamicSolutions query = do known <- getKnowledge getAllSolutions (\x -> known (query x)) --- Returns an answer to an abstraction on a dynamic expression. --- Returns Nothing if no answer exists. --- If other processes made changes to persistent predicates, --- these changes are read and made visible to the currently running program. getDynamicSolution :: (a -> Dynamic) -> IO (Maybe a) getDynamicSolution query = do known <- getKnowledge getOneSolution (\x -> known (query x)) --- Returns True if there exists the argument facts (without free variables!) --- and False, otherwise. isKnown :: Dynamic -> IO Bool isKnown (Dynamic spec) = do known <- getDynamicKnowledge first <- getOneSolution (\_ -> known (Dynamic spec)) return (first /= Nothing) isKnown (Prod d1 d2) = do b1 <- isKnown d1 b2 <- isKnown d2 return (b1&&b2) isKnown (Cond d c) = do b <- isKnown d return (b&&c) --- Perform an action (usually containing updates of various --- dynamic predicates) as a single transaction. --- This is the preferred way to execute any changes to persistent --- dynamic predicates if there might be more than one process --- that may modify the definition of such predicates in parallel. --- --- Before the transaction is executed, the access to all persistent --- predicates is locked (i.e., no other process can perform a --- transaction in parallel). --- After the successful transaction, the access is unlocked so that --- the updates performed in this transaction become persistent and --- visible to other processes. --- Otherwise (i.e., in case of a failure or abort of the transaction), --- the changes of the transaction to persistent predicates are --- ignored and Nothing is returned. --- --- In general, a transaction should terminate and all failures inside --- a transaction should be handled (execept for abortTransaction). --- If a transaction is externally interrupted (e.g., by killing the process), --- some locks might never be removed. However, they --- can be explicitly removed by deleting the corresponding lock files --- reported at startup time. --- --- Nested transactions are not supported and lead to a failure. transaction :: IO a -> IO (Maybe a) transaction action = do tnr <- startTransaction catch (performTrans tnr) (\e -> catch abortTransaction -- we perform an explicit abort in -- case of run time errors in action (\_ -> putStrLn (showError e) >> return Nothing)) where performTrans tnr = do result <- action commitTransaction tnr return (Just result) --- Perform an action (usually containing updates of various --- dynamic predicates) as a single transaction. --- This is similar to transaction but an execution --- error is caught and returned instead of printing it. transactionWithErrorCatch :: IO a -> IO (Either a IOError) transactionWithErrorCatch action = do tnr <- startTransaction catch (performTrans tnr) (\e -> catch abortTransaction -- we perform an explicit abort in -- case of run time errors in action (\_ -> return (Right e))) where performTrans tnr = do result <- action commitTransaction tnr return (Left result) --- Aborts the current transaction. If a transaction is aborted, --- the remaining actions of the transaction are not executed --- and all changes to persistent dynamic predicates --- made in this transaction are ignored. --- --- abortTransaction should only be used in a transaction. --- Although the execution of abortTransaction always fails --- (basically, it writes an abort record in log files, unlock them --- and then fails), the failure is handled inside transaction. abortTransaction :: IO _ abortTransaction external ------------------------------------------------------------------------ -- Internals... -- Asserts a new fact (without free variables!) about a dynamic predicate. assertFact :: Dynamic -> IO () assertFact pred = prim_assertFact $## pred prim_assertFact :: Dynamic -> IO () prim_assertFact external -- Deletes a fact (without free variables!) about a dynamic predicate. -- Returns True if there was such a fact and False, otherwise. retractFact :: Dynamic -> IO Bool retractFact pred = prim_retractFact $## pred prim_retractFact :: Dynamic -> IO Bool prim_retractFact external -- Returns the knowledge at a particular point of time about all dynamic -- predicates. If other processes made changes to persistent predicates, -- these changes are read and made visible to the currently running program. getDynamicKnowledge :: IO (Dynamic -> Bool) getDynamicKnowledge external -- To implement transactions: lock persistent files, load newest version, -- and mark begin of transaction in log files startTransaction :: IO Int startTransaction external -- To implement transactions: mark end of transaction in log files and -- unlock persistent files commitTransaction :: Int -> IO () commitTransaction t = prim_commitTransaction $# t prim_commitTransaction :: Int -> IO () prim_commitTransaction external -- ...to implement getKnowledge: isKnownAtTime :: Int -> Dynamic -> Bool isKnownAtTime t dyn = (prim_isKnownAtTime $# t) $!! dyn prim_isKnownAtTime :: Int -> Dynamic -> Bool prim_isKnownAtTime external curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Dynamic.prim_c2p000066400000000000000000000021021305333611600242440ustar00rootroot00000000000000 prim_dynamic prim_assertFact prim_dynamic prim_retractFact prim_dynamic prim_getDynamicKnowledge prim_dynamic prim_isKnownAtTime prim_dynamic prim_startTransaction prim_dynamic prim_commitTransaction prim_dynamic prim_abortTransaction curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Either.curry000066400000000000000000000032231305333611600235360ustar00rootroot00000000000000--- ---------------------------------------------------------------------------- --- Library with some useful operations for the `Either` data type. --- --- @author Bjoern Peemoeller --- @version March 2015 --- @category general --- ---------------------------------------------------------------------------- {-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-} module Either ( Either (..) , either , lefts , rights , isLeft , isRight , fromLeft , fromRight , partitionEithers ) where --- Extracts from a list of `Either` all the `Left` elements in order. lefts :: [Either a b] -> [a] lefts x = [a | Left a <- x] --- Extracts from a list of `Either` all the `Right` elements in order. rights :: [Either a b] -> [b] rights x = [a | Right a <- x] --- Return `True` if the given value is a `Left`-value, `False` otherwise. isLeft :: Either a b -> Bool isLeft (Left _) = True isLeft (Right _) = False --- Return `True` if the given value is a `Right`-value, `False` otherwise. isRight :: Either a b -> Bool isRight (Left _) = False isRight (Right _) = True --- Extract the value from a `Left` constructor. fromLeft :: Either a _ -> a fromLeft (Left x) = x --- Extract the value from a `Right` constructor. fromRight :: Either _ b -> b fromRight (Right x) = x --- Partitions a list of `Either` into two lists. --- All the `Left` elements are extracted, in order, to the first --- component of the output. Similarly the `Right` elements are extracted --- to the second component of the output. partitionEithers :: [Either a b] -> ([a],[b]) partitionEithers = foldr (either left right) ([],[]) where left a (l, r) = (a:l, r) right a (l, r) = (l, a:r) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/ErrorState.curry000066400000000000000000000045101305333611600244100ustar00rootroot00000000000000--- --------------------------------------------------------------------------- --- A combination of Error and state monad like `ErrorT State` in Haskell. --- --- @author Bjoern Peemoeller --- @version September 2014 --- @category general --- ---------------------------------------------------------------------------- module ErrorState where infixl 1 >+, >+= infixl 4 <$>, <*> --- Error state monad. type ES e s a = s -> Either e (a, s) --- Evaluate an `ES` monad evalES :: ES e s a -> s -> Either e a evalES m s = case m s of Left e -> Left e Right (x, _) -> Right x --- Lift a value into the `ES` monad returnES :: a -> ES e s a returnES x s = Right (x, s) --- Failing computation in the `ES` monad failES :: e -> ES e s a failES e _ = Left e --- Bind of the `ES` monad (>+=) :: ES e s a -> (a -> ES e s b) -> ES e s b m >+= f = \s -> case m s of Left e -> Left e Right (x, s') -> f x s' --- Sequence operator of the `ES` monad (>+) :: ES e s a -> ES e s b -> ES e s b m >+ n = m >+= \_ -> n --- Apply a pure function onto a monadic value. (<$>) :: (a -> b) -> ES e s a -> ES e s b f <$> act = act >+= \x -> returnES (f x) --- Apply a function yielded by a monadic action to a monadic value. (<*>) :: ES e s (a -> b) -> ES e s a -> ES e s b sf <*> sx = sf >+= \f -> sx >+= \x -> returnES (f x) --- Retrieve the current state gets :: ES e s s gets s = Right (s, s) --- Replace the current state puts :: s -> ES e s () puts s _ = Right ((), s) --- Modify the current state modify :: (s -> s) -> ES e s () modify f s = Right ((), f s) --- Map a monadic function on all elements of a list by sequencing --- the effects. mapES :: (a -> ES e s b) -> [a] -> ES e s [b] mapES _ [] = returnES [] mapES f (x : xs) = f x >+= \y -> mapES f xs >+= \ys -> returnES (y:ys) --- Same as `concatMap`, but for a monadic function. concatMapES :: (a -> ES e s [b]) -> [a] -> ES e s [b] concatMapES f xs = concat <$> mapES f xs --- Same as `mapES` but with an additional accumulator threaded through. mapAccumES :: (a -> b -> ES e s (a, c)) -> a -> [b] -> ES e s (a, [c]) mapAccumES _ s [] = returnES (s, []) mapAccumES f s (x : xs) = f s x >+= \(s', y) -> mapAccumES f s' xs >+= \(s'', ys) -> returnES (s'', y:ys) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/External_Directory.hs000066400000000000000000000056421305333611600254010ustar00rootroot00000000000000import System.Directory import System.IO import System.Time external_d_C_prim_doesFileExist :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Bool external_d_C_prim_doesFileExist s _ _ = toCurry doesFileExist s external_d_C_prim_doesDirectoryExist :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Bool external_d_C_prim_doesDirectoryExist s _ _ = toCurry doesDirectoryExist s external_d_C_prim_fileSize :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Int external_d_C_prim_fileSize s _ _ = toCurry (\f -> do h <- openFile f ReadMode i <- hFileSize h hClose h return i ) s external_d_C_prim_getModificationTime :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Time.C_ClockTime external_d_C_prim_getModificationTime s _ _ = toCurry getModificationTime s external_d_C_getCurrentDirectory :: Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.C_String) external_d_C_getCurrentDirectory _ _ = toCurry getCurrentDirectory external_d_C_prim_setCurrentDirectory :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_setCurrentDirectory s _ _ = toCurry setCurrentDirectory s external_d_C_prim_getDirectoryContents :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_List (Curry_Prelude.C_String)) external_d_C_prim_getDirectoryContents s _ _ = toCurry getDirectoryContents s external_d_C_prim_createDirectory :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_createDirectory s _ _ = toCurry createDirectory s external_d_C_prim_removeFile :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_removeFile s _ _ = toCurry removeFile s external_d_C_prim_removeDirectory :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_removeDirectory s _ _ = toCurry removeDirectory s external_d_C_prim_renameFile :: Curry_Prelude.C_String -> Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_renameFile s1 s2 _ _ = toCurry renameFile s1 s2 external_d_C_prim_renameDirectory :: Curry_Prelude.C_String -> Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_renameDirectory s1 s2 _ _= toCurry renameDirectory s1 s2 curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/External_Distribution.hs000066400000000000000000000020061305333611600261030ustar00rootroot00000000000000import qualified Installation as I external_d_C_curryCompiler :: Cover -> ConstStore -> Curry_Prelude.C_String external_d_C_curryCompiler _ _ = toCurry "kics2" external_d_C_curryCompilerMajorVersion :: Cover -> ConstStore -> Curry_Prelude.C_Int external_d_C_curryCompilerMajorVersion _ _ = toCurry I.majorVersion external_d_C_curryCompilerMinorVersion :: Cover -> ConstStore -> Curry_Prelude.C_Int external_d_C_curryCompilerMinorVersion _ _ = toCurry I.minorVersion external_d_C_curryRuntime :: Cover -> ConstStore -> Curry_Prelude.C_String external_d_C_curryRuntime _ _ = toCurry I.runtime external_d_C_curryRuntimeMajorVersion :: Cover -> ConstStore -> Curry_Prelude.C_Int external_d_C_curryRuntimeMajorVersion _ _ = toCurry I.runtimeMajor external_d_C_curryRuntimeMinorVersion :: Cover -> ConstStore -> Curry_Prelude.C_Int external_d_C_curryRuntimeMinorVersion _ _ = toCurry I.runtimeMinor external_d_C_installDir :: Cover -> ConstStore -> Curry_Prelude.C_String external_d_C_installDir _ _ = toCurry I.installDir curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/External_Float.hs000066400000000000000000000074421305333611600245020ustar00rootroot00000000000000external_d_C_prim_Float_plus :: Curry_Prelude.C_Float -> Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_Float_plus y x _ _ = toCurry ((fromCurry x + fromCurry y) :: Float) external_d_C_prim_Float_minus :: Curry_Prelude.C_Float -> Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_Float_minus y x _ _ = toCurry ((fromCurry x - fromCurry y) :: Float) external_d_C_prim_Float_times :: Curry_Prelude.C_Float -> Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_Float_times y x _ _ = toCurry ((fromCurry x * fromCurry y) :: Float) external_d_C_prim_Float_div :: Curry_Prelude.C_Float -> Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_Float_div y x _ _ = toCurry ((fromCurry x / fromCurry y) :: Float) external_d_C_prim_i2f :: Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_i2f x _ _ = toCurry (fromInteger (fromCurry x) :: Float) external_d_C_prim_truncate :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Int external_d_C_prim_truncate x _ _ = toCurry (truncate (fromCurry x :: Float) :: Int) external_d_C_prim_round :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Int external_d_C_prim_round x _ _ = toCurry (round (fromCurry x :: Float) :: Int) external_d_C_prim_sqrt :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_sqrt x _ _ = toCurry (sqrt (fromCurry x :: Float)) external_d_C_prim_log :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_log x _ _ = toCurry (log (fromCurry x :: Float)) external_d_C_prim_exp :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_exp x _ _ = toCurry (exp (fromCurry x :: Float)) external_d_C_prim_sin :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_sin x _ _ = toCurry (sin (fromCurry x :: Float)) external_d_C_prim_asin :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_asin x _ _ = toCurry (asin (fromCurry x :: Float)) external_d_C_prim_sinh :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_sinh x _ _ = toCurry (sinh (fromCurry x :: Float)) external_d_C_prim_asinh :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_asinh x _ _ = toCurry (asinh (fromCurry x :: Float)) external_d_C_prim_cos :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_cos x _ _ = toCurry (cos (fromCurry x :: Float)) external_d_C_prim_acos :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_acos x _ _ = toCurry (acos (fromCurry x :: Float)) external_d_C_prim_cosh :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_cosh x _ _ = toCurry (cosh (fromCurry x :: Float)) external_d_C_prim_acosh :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_acosh x _ _ = toCurry (acosh (fromCurry x :: Float)) external_d_C_prim_tan :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_tan x _ _ = toCurry (tan (fromCurry x :: Float)) external_d_C_prim_atan :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_atan x _ _ = toCurry (atan (fromCurry x :: Float)) external_d_C_prim_tanh :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_tanh x _ _ = toCurry (tanh (fromCurry x :: Float)) external_d_C_prim_atanh :: Curry_Prelude.C_Float -> Cover -> ConstStore -> Curry_Prelude.C_Float external_d_C_prim_atanh x _ _ = toCurry (atanh (fromCurry x :: Float))curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/External_Global.hs000066400000000000000000000146471305333611600246420ustar00rootroot00000000000000import CurryException import Control.Exception as C import Data.IORef import System.IO import System.Directory (doesFileExist) import System.IO.Unsafe import System.Process (system) -- Implementation of Globals in Curry. We use Haskell's IORefs for temporary -- globals where Curry values are stored in the IORefs data C_Global a = Choice_C_Global Cover ID (C_Global a) (C_Global a) | Choices_C_Global Cover ID ([C_Global a]) | Fail_C_Global Cover FailInfo | Guard_C_Global Cover Constraints (C_Global a) | C_Global_Temp (IORef a) -- a temporary global | C_Global_Pers String -- a persistent global with a given (file) name instance Show (C_Global a) where show = error "ERROR: no show for Global" instance Read (C_Global a) where readsPrec = error "ERROR: no read for Global" instance NonDet (C_Global a) where choiceCons = Choice_C_Global choicesCons = Choices_C_Global failCons = Fail_C_Global guardCons = Guard_C_Global try (Choice_C_Global cd i x y) = tryChoice cd i x y try (Choices_C_Global cd i xs) = tryChoices cd i xs try (Fail_C_Global cd info) = Fail cd info try (Guard_C_Global cd c e) = Guard cd c e try x = Val x match choiceF _ _ _ _ _ (Choice_C_Global cd i x y) = choiceF cd i x y match _ narrF _ _ _ _ (Choices_C_Global cd i@(NarrowedID _ _) xs) = narrF cd i xs match _ _ freeF _ _ _ (Choices_C_Global cd i@(FreeID _ _) xs) = freeF cd i xs match _ _ _ failF _ _ (Fail_C_Global cd info) = failF cd info match _ _ _ _ guardF _ (Guard_C_Global cd c e) = guardF cd c e match _ _ _ _ _ valF x = valF x instance Generable (C_Global a) where generate _ _ = error "ERROR: no generator for Global" instance NormalForm (C_Global a) where ($!!) cont g@(C_Global_Temp _) cd cs = cont g cd cs ($!!) cont g@(C_Global_Pers _) cd cs = cont g cd cs ($!!) cont (Choice_C_Global d i g1 g2) cd cs = nfChoice cont d i g1 g2 cd cs ($!!) cont (Choices_C_Global d i gs) cd cs = nfChoices cont d i gs cd cs ($!!) cont (Guard_C_Global d c g) cd cs = guardCons d c ((cont $!! g) cd $! (addCs c cs)) ($!!) _ (Fail_C_Global d info) _ _ = failCons d info ($##) cont g@(C_Global_Temp _) cd cs = cont g cd cs ($##) cont g@(C_Global_Pers _) cd cs = cont g cd cs ($##) cont (Choice_C_Global d i g1 g2) cd cs = gnfChoice cont d i g1 g2 cd cs ($##) cont (Choices_C_Global d i gs) cd cs = gnfChoices cont d i gs cd cs ($##) cont (Guard_C_Global d c g) cd cs = guardCons d c ((cont $## g) cd $! (addCs c cs)) ($##) _ (Fail_C_Global cd info) _ _ = failCons cd info searchNF _ cont g@(C_Global_Temp _) = cont g searchNF _ cont g@(C_Global_Pers _) = cont g instance Unifiable (C_Global a) where (=.=) (C_Global_Temp ref1) (C_Global_Temp ref2) _ _ | ref1 == ref2 = C_True (=.=) (C_Global_Pers f1) (C_Global_Pers f2) _ _ | f1 == f2 = C_True (=.=) _ _ cd _ = Fail_C_Bool cd defFailInfo (=.<=) = (=.=) bind cd i (Choice_C_Global d j l r) = [(ConstraintChoice d j (bind cd i l) (bind cd i r))] bind cd i (Choices_C_Global d j@(FreeID _ _) xs) = bindOrNarrow cd i d j xs bind cd i (Choices_C_Global d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (bind cd i) xs))] bind _ _ (Fail_C_Global _ info) = [Unsolvable info] bind cd i (Guard_C_Global _ cs e) = (getConstrList cs) ++ (bind cd i e) lazyBind cd i (Choice_C_Global d j l r) = [(ConstraintChoice d j (lazyBind cd i l) (lazyBind cd i r))] lazyBind cd i (Choices_C_Global d j@(FreeID _ _) xs) = lazyBindOrNarrow cd i d j xs lazyBind cd i (Choices_C_Global d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (lazyBind cd i) xs))] lazyBind _ _ (Fail_C_Global cd info) = [Unsolvable info] lazyBind cd i (Guard_C_Global _ cs e) = (getConstrList cs) ++ [(i :=: (LazyBind (lazyBind cd i e)))] instance Curry_Prelude.Curry a => Curry_Prelude.Curry (C_Global a) where (=?=) = error "(==) is undefined for Globals" ( a -> C_GlobalSpec -> Cover -> ConstStore -> C_Global a external_d_C_global val C_Temporary _ _ = ref `seq` (C_Global_Temp ref) where ref = unsafePerformIO (newIORef val) external_d_C_global val (C_Persistent cname) _ _ = let name = fromCurry cname :: String in unsafePerformIO (initGlobalFile name >> return (C_Global_Pers name)) where initGlobalFile name = do ex <- doesFileExist name if ex then return () else writeFile name (show val++"\n") external_d_C_prim_readGlobal :: Curry_Prelude.Curry a => C_Global a -> Cover -> ConstStore -> Curry_Prelude.C_IO a external_d_C_prim_readGlobal (C_Global_Temp ref) _ _ = fromIO (readIORef ref) external_d_C_prim_readGlobal (C_Global_Pers name) _ _ = fromIO $ exclusiveOnFile name $ do s <- catch (do h <- openFile name ReadMode eof <- hIsEOF h s <- if eof then return "" else hGetLine h hClose h return s) (\e -> throw (IOException (show (e :: C.IOException)))) case reads s of [(val,"")] -> return val _ -> throw (IOException $ "Persistent file `" ++ name ++ "' contains malformed contents") external_d_C_prim_writeGlobal :: Curry_Prelude.Curry a => C_Global a -> a -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_writeGlobal (C_Global_Temp ref) val _ _ = toCurry (writeIORef ref val) external_d_C_prim_writeGlobal (C_Global_Pers name) val _ _ = toCurry (exclusiveOnFile name $ writeFile name (show val ++ "\n")) --- Forces the exclusive execution of an action via a lock file. exclusiveOnFile :: String -> IO a -> IO a exclusiveOnFile file action = do exlock <- doesFileExist lockfile if exlock then hPutStrLn stderr (">>> Waiting for removing lock file `" ++ lockfile ++ "'...") else return () system ("lockfile-create --lock-name "++lockfile) C.catch (do actionResult <- action deleteLockFile return actionResult ) (\e -> deleteLockFile >> C.throw (e :: CurryException)) where lockfile = file ++ ".LOCK" deleteLockFile = system $ "lockfile-remove --lock-name " ++ lockfile curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/External_IO.hs000066400000000000000000000124251305333611600237410ustar00rootroot00000000000000{-# LANGUAGE MultiParamTypeClasses #-} import Control.Concurrent import qualified Control.Exception as C (IOException, catch, throw) import Control.Monad (zipWithM) import System.IO import System.IO.Error (isEOFError) type C_Handle = PrimData CurryHandle instance ConvertCurryHaskell C_IOMode IOMode where toCurry ReadMode = C_ReadMode toCurry WriteMode = C_WriteMode toCurry AppendMode = C_AppendMode fromCurry C_ReadMode = ReadMode fromCurry C_WriteMode = WriteMode fromCurry C_AppendMode = AppendMode fromCurry _ = error "IOMode data with no ground term occurred" instance ConvertCurryHaskell C_SeekMode SeekMode where toCurry AbsoluteSeek = C_AbsoluteSeek toCurry RelativeSeek = C_RelativeSeek toCurry SeekFromEnd = C_SeekFromEnd fromCurry C_AbsoluteSeek = AbsoluteSeek fromCurry C_RelativeSeek = RelativeSeek fromCurry C_SeekFromEnd = SeekFromEnd fromCurry _ = error "SeekMode data with no ground term occurred" external_d_C_stdin :: Cover -> ConstStore -> C_Handle external_d_C_stdin _ _ = PrimData (OneHandle stdin) external_d_C_stdout :: Cover -> ConstStore -> C_Handle external_d_C_stdout _ _ = PrimData (OneHandle stdout) external_d_C_stderr :: Cover -> ConstStore -> C_Handle external_d_C_stderr _ _ = PrimData (OneHandle stderr) external_d_C_prim_openFile :: Curry_Prelude.OP_List Curry_Prelude.C_Char -> C_IOMode -> Cover -> ConstStore -> Curry_Prelude.C_IO C_Handle external_d_C_prim_openFile fn mode _ _ = toCurry (\s m -> openFile s m >>= return . OneHandle) fn mode external_d_C_prim_hClose :: C_Handle -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_hClose handle _ _ = toCurry (\ch -> case ch of OneHandle h -> hClose h InOutHandle h1 h2 -> hClose h1 >> hClose h2) handle external_d_C_prim_hFlush :: C_Handle -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_hFlush h _ _ = toCurry (hFlush . outputHandle) h external_d_C_prim_hIsEOF :: C_Handle -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Bool external_d_C_prim_hIsEOF h _ _ = toCurry (hIsEOF . inputHandle) h external_d_C_prim_hSeek :: C_Handle -> C_SeekMode -> Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_hSeek handle mode i _ _ = toCurry (hSeek . inputHandle) handle mode i external_d_C_prim_hWaitForInput :: C_Handle -> Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Bool external_d_C_prim_hWaitForInput handle timeout _ _ = toCurry (myhWaitForInput . inputHandle) handle timeout myhWaitForInput :: Handle -> Int -> IO Bool myhWaitForInput h timeout = C.catch (hWaitForInput h timeout) handler where handler :: C.IOException -> IO Bool handler e = if isEOFError e then return False else C.throw e external_d_C_prim_hWaitForInputs :: Curry_Prelude.OP_List C_Handle -> Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Int external_d_C_prim_hWaitForInputs hs i _ _ = toCurry selectHandle hs i selectHandle :: [CurryHandle] -> Int -> IO Int selectHandle handles timeout = do mvar <- newEmptyMVar threads <- zipWithM (\ i h -> forkIO (waitOnHandle (inputHandle h) i timeout mvar)) [0 ..] handles inspectRes (length handles) mvar threads inspectRes :: Int -> MVar (Maybe Int) -> [ThreadId] -> IO Int inspectRes 0 _ _ = return (-1) inspectRes n mvar threads = do res <- takeMVar mvar case res of Nothing -> inspectRes (n - 1) mvar threads Just v -> mapM_ killThread threads >> return v waitOnHandle :: Handle -> Int -> Int -> MVar (Maybe Int) -> IO () waitOnHandle h v timeout mvar = do ready <- myhWaitForInput h timeout putMVar mvar (if ready then Just v else Nothing) external_d_C_prim_hWaitForInputsOrMsg :: Curry_Prelude.Curry a => Curry_Prelude.OP_List C_Handle -> Curry_Prelude.OP_List a -> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.C_Either Curry_Prelude.C_Int (Curry_Prelude.OP_List a)) external_d_C_prim_hWaitForInputsOrMsg = error "hWaitForInputsOrMsg undefined" external_d_C_prim_hGetChar :: C_Handle -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Char external_d_C_prim_hGetChar h _ _ = toCurry (hGetChar . inputHandle) h external_d_C_prim_hPutChar :: C_Handle -> Curry_Prelude.C_Char -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_hPutChar h c _ _ = toCurry (hPutChar . outputHandle) h c external_d_C_prim_hIsReadable :: C_Handle -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Bool external_d_C_prim_hIsReadable h _ _ = toCurry (hIsReadable . inputHandle) h external_d_C_prim_hIsWritable :: C_Handle -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Bool external_d_C_prim_hIsWritable h _ _ = toCurry (hIsWritable . outputHandle) h external_d_C_prim_hIsTerminalDevice :: C_Handle -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Bool external_d_C_prim_hIsTerminalDevice h _ _ = toCurry (hIsTerminalDevice . outputHandle) h curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/External_IOExts.hs000066400000000000000000000153571305333611600246140ustar00rootroot00000000000000{-# LANGUAGE MultiParamTypeClasses #-} import Data.IORef import System.IO.Unsafe (unsafePerformIO) -- for global associations import System.Process (readProcessWithExitCode, runInteractiveCommand) import Control.Concurrent (forkIO) import System.IO external_d_C_prim_execCmd :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple3 Curry_IO.C_Handle Curry_IO.C_Handle Curry_IO.C_Handle) external_d_C_prim_execCmd str _ _ = toCurry (\s -> do (h1,h2,h3,_) <- runInteractiveCommand s return (OneHandle h1, OneHandle h2, OneHandle h3)) str external_d_C_prim_evalCmd :: Curry_Prelude.C_String -> Curry_Prelude.OP_List Curry_Prelude.C_String -> Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple3 Curry_Prelude.C_Int Curry_Prelude.C_String Curry_Prelude.C_String) external_d_C_prim_evalCmd cmd args input _ _ = toCurry readProcessWithExitCode cmd args input external_d_C_prim_connectToCmd :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_IO.C_Handle external_d_C_prim_connectToCmd str _ _ = toCurry (\s -> do (hin,hout,herr,_) <- runInteractiveCommand s forkIO (forwardError herr) return (InOutHandle hout hin)) str forwardError :: Handle -> IO () forwardError h = do eof <- hIsEOF h if eof then return () else hGetLine h >>= hPutStrLn stderr >> forwardError h ----------------------------------------------------------------------- -- Implementation of global associations as simple association lists -- (could be later improved by a more efficient implementation, e.g., maps) type Assocs = [(String,String)] assocs :: IORef Assocs assocs = unsafePerformIO (newIORef []) external_d_C_prim_setAssoc :: Curry_Prelude.C_String -> Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_setAssoc str1 str2 _ _ = toCurry (\key val -> do as <- readIORef assocs writeIORef assocs ((key,val):as)) str1 str2 external_d_C_prim_getAssoc :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.C_Maybe (Curry_Prelude.C_String)) external_d_C_prim_getAssoc str _ _ = toCurry (\key -> do as <- readIORef assocs return (lookup key as)) str ----------------------------------------------------------------------- -- Implementation of IORefs in Curry. Note that we store Curry values -- (and not the corresponding Haskell values) in the Haskell IORefs data C_IORef a = Choice_C_IORef Cover ID (C_IORef a) (C_IORef a) | Choices_C_IORef Cover ID ([C_IORef a]) | Fail_C_IORef Cover FailInfo | Guard_C_IORef Cover Constraints (C_IORef a) | C_IORef (IORef a) instance Show (C_IORef a) where show = error "ERROR: no show for IORef" instance Read (C_IORef a) where readsPrec = error "ERROR: no read for IORef" instance NonDet (C_IORef a) where choiceCons = Choice_C_IORef choicesCons = Choices_C_IORef failCons = Fail_C_IORef guardCons = Guard_C_IORef try (Choice_C_IORef cd i x y) = tryChoice cd i x y try (Choices_C_IORef cd s xs) = tryChoices cd s xs try (Fail_C_IORef cd info) = Fail cd info try (Guard_C_IORef cd c e) = Guard cd c e try x = Val x match f _ _ _ _ _ (Choice_C_IORef cd i x y) = f cd i x y match _ f _ _ _ _ (Choices_C_IORef cd i@(NarrowedID _ _) xs) = f cd i xs match _ _ f _ _ _ (Choices_C_IORef cd i@(FreeID _ _) xs) = f cd i xs match _ _ _ _ _ _ (Choices_C_IORef _ i _) = error ("IOExts.IORef.match: Choices with ChoiceID " ++ show i) match _ _ _ f _ _ (Fail_C_IORef cd info) = f cd info match _ _ _ _ f _ (Guard_C_IORef cd cs e) = f cd cs e match _ _ _ _ _ f x = f x instance Generable (C_IORef a) where generate _ _ = error "ERROR: no generator for IORef" instance NormalForm (C_IORef a) where ($!!) cont ioref@(C_IORef _) cd cs = cont ioref cd cs ($!!) cont (Choice_C_IORef d i io1 io2) cd cs = nfChoice cont d i io1 io2 cd cs ($!!) cont (Choices_C_IORef d i ios) cd cs = nfChoices cont d i ios cd cs ($!!) cont (Guard_C_IORef d c io) cd cs = guardCons d c ((cont $!! io) cd $! (addCs c cs)) ($!!) _ (Fail_C_IORef d info) _ _ = failCons d info ($##) cont io@(C_IORef _) cd cs = cont io cd cs ($##) cont (Choice_C_IORef d i io1 io2) cd cs = gnfChoice cont d i io1 io2 cd cs ($##) cont (Choices_C_IORef d i ios) cd cs = gnfChoices cont d i ios cd cs ($##) cont (Guard_C_IORef d c io) cd cs = guardCons d c ((cont $## io) cd $! (addCs c cs)) ($##) _ (Fail_C_IORef d info) cd cs = failCons d info searchNF _ cont ioref@(C_IORef _) = cont ioref instance Unifiable (C_IORef a) where (=.=) _ _ = error "(=.=) for C_IORef" (=.<=) _ _ = error "(=.<=) for C_IORef" bind cd i (Choice_C_IORef d j l r) = [(ConstraintChoice d j (bind cd i l) (bind cd i r))] bind cd i (Choices_C_IORef d j@(FreeID _ _) xs) = bindOrNarrow cd i d j xs bind cd i (Choices_C_IORef d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (bind cd i) xs))] bind _ _ (Fail_C_IORef cd info) = [Unsolvable info] bind cd i (Guard_C_IORef _ cs e) = (getConstrList cs) ++ (bind cd i e) lazyBind cd i (Choice_C_IORef d j l r) = [(ConstraintChoice d j (lazyBind cd i l) (lazyBind cd i r))] lazyBind cd i (Choices_C_IORef d j@(FreeID _ _) xs) = lazyBindOrNarrow cd i d j xs lazyBind cd i (Choices_C_IORef d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (lazyBind cd i) xs))] lazyBind _ _ (Fail_C_IORef cd info) = [Unsolvable info] lazyBind cd i (Guard_C_IORef _ cs e) = (getConstrList cs) ++ [(i :=: (LazyBind (lazyBind cd i e)))] instance Curry_Prelude.Curry a => Curry_Prelude.Curry (C_IORef a) where (=?=) = error "(==) is undefined for IORefs" ( a -> Cover -> ConstStore -> Curry_Prelude.C_IO (C_IORef a) external_d_C_newIORef cv _ _ = toCurry (newIORef cv) external_d_C_prim_readIORef :: Curry_Prelude.Curry a => C_IORef a -> Cover -> ConstStore -> Curry_Prelude.C_IO a external_d_C_prim_readIORef ref _ _ = fromIO (readIORef (fromCurry ref)) external_d_C_prim_writeIORef :: Curry_Prelude.Curry a => C_IORef a -> a -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_writeIORef ref cv _ _ = toCurry (writeIORef (fromCurry ref) cv) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/External_Prelude.hs000066400000000000000000002574001305333611600250360ustar00rootroot00000000000000{-# LANGUAGE BangPatterns, CPP, MagicHash #-} {-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-} import qualified Control.Exception as C -- ATTENTION: Do not introduce line breaks in import declarations as these -- are not recognized! import GHC.Exts (Int (I#), Int#, (==#), (/=#), (<#), (>#), (<=#)) import GHC.Exts ((+#), (-#), (*#), quotInt#, remInt#, negateInt#) import GHC.Exts (Float (F#), Float#, eqFloat#, leFloat#, negateFloat#) import GHC.Exts (Char (C#), Char#, eqChar#, leChar#, ord#, chr#) import System.IO import CurryException import KiCS2Debug (internalError) import FailInfo (customFail) import PrimTypes #if __GLASGOW_HASKELL__ > 706 import GHC.Exts (isTrue#) #endif -- #endimport - do not remove this line! #if !(__GLASGOW_HASKELL__ > 706) isTrue# :: Bool -> Bool {-# INLINE isTrue# #-} isTrue# x = x #endif -- ----------------------------------------------------------------------------- -- Int representation -- ----------------------------------------------------------------------------- -- BEGIN GENERATED FROM PrimTypes.curry data C_Int = C_Int Int# | C_CurryInt BinInt | Choice_C_Int Cover ID C_Int C_Int | Choices_C_Int Cover ID ([C_Int]) | Fail_C_Int Cover FailInfo | Guard_C_Int Cover Constraints C_Int instance Show C_Int where showsPrec d (Choice_C_Int cd i x y) = showsChoice d cd i x y showsPrec d (Choices_C_Int cd i xs) = showsChoices d cd i xs showsPrec d (Guard_C_Int cd c e) = showsGuard d cd c e showsPrec _ (Fail_C_Int _ _) = showChar '!' showsPrec d (C_Int x1) = shows (I# x1) showsPrec d (C_CurryInt x1) = case ((\x _ _ -> x) $## x1) (error "Show C_Int: nesting depth used") emptyCs of Choice_BinInt _ _ _ _ -> shows x1 Choices_BinInt _ _ _ -> shows x1 Fail_BinInt _ _ -> shows x1 Guard_BinInt _ _ _ -> shows x1 gnfBinInt -> shows (I# (curryint2primint gnfBinInt)) instance Read C_Int where readsPrec d s = map readInt (readsPrec d s) where readInt (I# i, s) = (C_Int i, s) instance NonDet C_Int where choiceCons = Choice_C_Int choicesCons = Choices_C_Int failCons = Fail_C_Int guardCons = Guard_C_Int try (Choice_C_Int cd i x y) = tryChoice cd i x y try (Choices_C_Int cd i xs) = tryChoices cd i xs try (Fail_C_Int cd info) = Fail cd info try (Guard_C_Int cd c e) = Guard cd c e try x = Val x match f _ _ _ _ _ (Choice_C_Int cd i x y) = f cd i x y match _ f _ _ _ _ (Choices_C_Int cd i@(NarrowedID _ _) xs) = f cd i xs match _ _ f _ _ _ (Choices_C_Int cd i@(FreeID _ _) xs) = f cd i xs match _ _ _ _ _ _ (Choices_C_Int _ i _) = error ("Prelude.Int.match: Choices with ChoiceID " ++ (show i)) match _ _ _ f _ _ (Fail_C_Int cd info) = f cd info match _ _ _ _ f _ (Guard_C_Int cd cs e) = f cd cs e match _ _ _ _ _ f x = f x instance Generable C_Int where generate s cd = Choices_C_Int cd (freeID [1] s) [C_CurryInt (generate (leftSupply s) cd)] instance NormalForm C_Int where ($!!) cont x@(C_Int _) cd cs = cont x cd cs ($!!) cont (C_CurryInt x1) cd cs = ((\y1 -> cont (C_CurryInt y1)) $!! x1) cd cs ($!!) cont (Choice_C_Int d i x y) cd cs = nfChoice cont d i x y cd cs ($!!) cont (Choices_C_Int d i xs) cd cs = nfChoices cont d i xs cd cs ($!!) cont (Guard_C_Int d c x) cd cs = guardCons d c ((cont $!! x) cd $! (addCs c cs)) ($!!) _ (Fail_C_Int cd info) _ _ = failCons cd info ($##) cont x@(C_Int _) cd cs = cont x cd cs ($##) cont (C_CurryInt x1) cd cs = ((\y1 -> cont (C_CurryInt y1)) $## x1) cd cs ($##) cont (Choice_C_Int d i x y) cd cs = gnfChoice cont d i x y cd cs ($##) cont (Choices_C_Int d i xs) cd cs = gnfChoices cont d i xs cd cs ($##) cont (Guard_C_Int d c x) cd cs = guardCons d c ((cont $## x) cd $! (addCs c cs)) ($##) _ (Fail_C_Int d info) _ _ = failCons d info searchNF search cont x@(C_Int _) = cont x searchNF search cont (C_CurryInt x1) = search (\y1 -> cont (C_CurryInt y1)) x1 searchNF _ _ x = error ("Prelude.Int.searchNF: no constructor: " ++ (show x)) instance Unifiable C_Int where (=.=) (C_Int x1) (C_Int y1) cd _ = if isTrue# (x1 ==# y1) then C_True else Fail_C_Bool cd defFailInfo (=.=) (C_Int x1) (C_CurryInt y1) cd cs = ((primint2curryint x1) =:= y1) cd cs (=.=) (C_CurryInt x1) (C_Int y1) cd cs = (x1 =:= (primint2curryint y1)) cd cs (=.=) (C_CurryInt x1) (C_CurryInt y1) cd cs = (x1 =:= y1) cd cs (=.=) _ _ cd _ = Fail_C_Bool cd defFailInfo (=.<=) (C_Int x1) (C_Int y1) cd _ = if isTrue# (x1 ==# y1) then C_True else Fail_C_Bool cd defFailInfo (=.<=) (C_Int x1) (C_CurryInt y1) cd cs = ((primint2curryint x1) =:<= y1) cd cs (=.<=) (C_CurryInt x1) (C_Int y1) cd cs = (x1 =:<= (primint2curryint y1)) cd cs (=.<=) (C_CurryInt x1) (C_CurryInt y1) cd cs = (x1 =:<= y1) cd cs (=.<=) _ _ cd _= Fail_C_Bool cd defFailInfo bind cd i (C_Int x2) = (i :=: ChooseN 0 1) : bind cd (leftID i) (primint2curryint x2) bind cd i (C_CurryInt x2) = (i :=: ChooseN 0 1) : bind cd (leftID i) x2 bind cd i (Choice_C_Int d j l r) = [(ConstraintChoice d j (bind cd i l) (bind cd i r))] bind cd i (Choices_C_Int d j@(FreeID _ _) xs) = bindOrNarrow cd i d j xs bind cd i (Choices_C_Int d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (bind cd i) xs))] bind _ _ c@(Choices_C_Int _ i@(ChoiceID _) _) = error ("Prelude.Int.bind: Choices with ChoiceID: " ++ (show c)) bind _ _ (Fail_C_Int _ info) = [Unsolvable info] bind cd i (Guard_C_Int _ cs e) = getConstrList cs ++ (bind cd i e) lazyBind cd i (C_Int x2) = [i :=: ChooseN 0 1, leftID i :=: LazyBind (lazyBind cd (leftID i) (primint2curryint x2))] lazyBind cd i (C_CurryInt x2) = [i :=: ChooseN 0 1, leftID i :=: LazyBind (lazyBind cd (leftID i) x2)] lazyBind cd i (Choice_C_Int d j l r) = [(ConstraintChoice d j (lazyBind cd i l) (lazyBind cd i r))] lazyBind cd i (Choices_C_Int d j@(FreeID _ _) xs) = lazyBindOrNarrow cd i d j xs lazyBind cd i (Choices_C_Int d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (lazyBind cd i) xs))] lazyBind _ _ c@(Choices_C_Int _ i@(ChoiceID _) _) = error ("Prelude.Int.lazyBind: Choices with ChoiceID: " ++ (show c)) lazyBind _ _ (Fail_C_Int _ info) = [Unsolvable info] lazyBind cd i (Guard_C_Int _ cs e) = getConstrList cs ++ [(i :=: (LazyBind (lazyBind cd i e)))] instance Curry C_Int where (=?=) (Choice_C_Int d i x y) z cd cs = narrow d i ((x =?= z) cd cs) ((y =?= z) cd cs) (=?=) (Choices_C_Int d i xs) y cd cs = narrows cs d i (\x -> (x =?= y) cd cs) xs (=?=) (Guard_C_Int d c x) y cd cs = guardCons d c ((x =?= y) cd $! (addCs c cs)) (=?=) (Fail_C_Int d info) _ _ _ = failCons d info (=?=) z (Choice_C_Int d i x y) cd cs = narrow d i ((z =?= x) cd cs) ((z =?= y) cd cs) (=?=) y (Choices_C_Int d i xs) cd cs = narrows cs d i (\x -> (y =?= x) cd cs) xs (=?=) y (Guard_C_Int d c x) cd cs = guardCons d c ((y =?= x) cd $! (addCs c cs)) (=?=) _ (Fail_C_Int d info) _ _ = failCons d info (=?=) (C_Int x1) (C_Int y1) _ _ = toCurry (isTrue# (x1 ==# y1)) (=?=) (C_Int x1) (C_CurryInt y1) cd cs = ((primint2curryint x1) =?= y1) cd cs (=?=) (C_CurryInt x1) (C_Int y1) cd cs = (x1 =?= (primint2curryint y1)) cd cs (=?=) (C_CurryInt x1) (C_CurryInt y1) cd cs = (x1 =?= y1) cd cs ( (x (y BinInt primint2curryint n | isTrue# (n <# 0#) = Neg (primint2currynat (negateInt# n)) | isTrue# (n ==# 0#) = Zero | otherwise = Pos (primint2currynat n) primint2currynat :: Int# -> Nat primint2currynat n | isTrue# (n ==# 1#) = IHi | isTrue# ((n `remInt#` 2#) ==# 0#) = O (primint2currynat (n `quotInt#` 2#)) | otherwise = I (primint2currynat (n `quotInt#` 2#)) curryint2primint :: BinInt -> Int# curryint2primint Zero = 0# curryint2primint (Pos n) = currynat2primint n curryint2primint (Neg n) = negateInt# (currynat2primint n) curryint2primint int = error ("KiCS2 error: Prelude.curryint2primint: no ground term, but " ++ show int) currynat2primint :: Nat -> Int# currynat2primint IHi = 1# currynat2primint (O n) = 2# *# currynat2primint n currynat2primint (I n) = 2# *# currynat2primint n +# 1# currynat2primint nat = error ("KiCS2 error: Prelude.currynat2primint: no ground term, but " ++ show nat) -- ----------------------------------------------------------------------------- -- Float representation -- ----------------------------------------------------------------------------- -- BEGIN GENERATED FROM PrimTypes.curry data C_Float = C_Float Float# | Choice_C_Float Cover ID C_Float C_Float | Choices_C_Float Cover ID ([C_Float]) | Fail_C_Float Cover FailInfo | Guard_C_Float Cover (Constraints) C_Float instance Show C_Float where showsPrec d (Choice_C_Float cd i x y) = showsChoice d cd i x y showsPrec d (Choices_C_Float cd i xs) = showsChoices d cd i xs showsPrec d (Guard_C_Float cd c e) = showsGuard d cd c e showsPrec d (Fail_C_Float _ _) = showChar '!' showsPrec d (C_Float x1) = shows (F# x1) instance Read C_Float where readsPrec d s = map readFloat (readsPrec d s) where readFloat (F# f, s) = (C_Float f, s) instance NonDet C_Float where choiceCons = Choice_C_Float choicesCons = Choices_C_Float failCons = Fail_C_Float guardCons = Guard_C_Float try (Choice_C_Float cd i x y) = tryChoice cd i x y try (Choices_C_Float cd i xs) = tryChoices cd i xs try (Fail_C_Float cd info) = Fail cd info try (Guard_C_Float cd c e) = Guard cd c e try x = Val x match f _ _ _ _ _ (Choice_C_Float cd i x y) = f cd i x y match _ f _ _ _ _ (Choices_C_Float cd i@(NarrowedID _ _) xs) = f cd i xs match _ _ f _ _ _ (Choices_C_Float cd i@(FreeID _ _) xs) = f cd i xs match _ _ _ _ _ _ (Choices_C_Float cd i@(ChoiceID _) _) = error ("Prelude.Float.match: Choices with ChoiceID " ++ (show i)) match _ _ _ f _ _ (Fail_C_Float cd info) = f cd info match _ _ _ _ f _ (Guard_C_Float cd cs e) = f cd cs e match _ _ _ _ _ f x = f x instance Generable C_Float where generate = error "No generator for C_Float" instance NormalForm C_Float where ($!!) cont x@(C_Float _) cd cs = cont x cd cs ($!!) cont (Choice_C_Float d i x y) cd cs = nfChoice cont d i x y cd cs ($!!) cont (Choices_C_Float d i xs) cd cs = nfChoices cont d i xs cd cs ($!!) cont (Guard_C_Float d c x) cd cs = guardCons d c ((cont $!! x) cd $! (addCs c cs)) ($!!) _ (Fail_C_Float d info) _ _ = failCons d info ($##) cont x@(C_Float _) cd cs = cont x cd cs ($##) cont (Choice_C_Float d i x y) cd cs = gnfChoice cont d i x y cd cs ($##) cont (Choices_C_Float d i xs) cd cs = gnfChoices cont d i xs cd cs ($##) cont (Guard_C_Float d c x) cd cs = guardCons d c ((cont $## x) cd $! (addCs c cs)) ($##) _ (Fail_C_Float d info) _ _ = failCons d info searchNF search cont x@(C_Float _) = cont x searchNF _ _ x = error ("Prelude.Float.searchNF: no constructor: " ++ (show x)) instance Unifiable C_Float where (=.=) (C_Float x1) (C_Float y1) cd _ = if isTrue# (x1 `eqFloat#` y1) then C_True else Fail_C_Bool cd defFailInfo (=.<=) (C_Float x1) (C_Float y1) cd _ = if isTrue# (x1 `eqFloat#` y1) then C_True else Fail_C_Bool cd defFailInfo bind cd i (Choice_C_Float d j l r) = [(ConstraintChoice d j (bind cd i l) (bind cd i r))] bind cd i (Choices_C_Float d j@(FreeID _ _) xs) = bindOrNarrow cd i d j xs bind cd i (Choices_C_Float d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (bind cd i) xs))] bind _ _ c@(Choices_C_Float _ i _) = error ("Prelude.Float.bind: Choices with ChoiceID: " ++ (show c)) bind _ _ (Fail_C_Float _ info) = [Unsolvable info] bind cd i (Guard_C_Float _ cs e) = getConstrList cs ++ (bind cd i e) lazyBind cd i (Choice_C_Float d j l r) = [(ConstraintChoice d j (lazyBind cd i l) (lazyBind cd i r))] lazyBind cd i (Choices_C_Float d j@(FreeID _ _) xs) = lazyBindOrNarrow cd i d j xs lazyBind cd i (Choices_C_Float d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (lazyBind cd i) xs))] lazyBind _ _ c@(Choices_C_Float _ i _) = error ("Prelude.Float.lazyBind: Choices with ChoiceID: " ++ (show c)) lazyBind _ _ (Fail_C_Float _ info) = [Unsolvable info] lazyBind cd i (Guard_C_Float _ cs e) = getConstrList cs ++ [(i :=: (LazyBind (lazyBind cd i e)))] instance Curry C_Float where (=?=) (Choice_C_Float d i x y) z cd cs = narrow d i ((x =?= z) cd cs) ((y =?= z) cd cs) (=?=) (Choices_C_Float d i xs) y cd cs = narrows cs d i (\x -> (x =?= y) cd cs) xs (=?=) (Guard_C_Float d c x) y cd cs = guardCons d c ((x =?= y) cd $! (addCs c cs)) (=?=) (Fail_C_Float d info) _ _ _= failCons d info (=?=) z (Choice_C_Float d i x y) cd cs = narrow d i ((z =?= x) cd cs) ((z =?= y) cd cs) (=?=) y (Choices_C_Float d i xs) cd cs = narrows cs d i (\x -> (y =?= x) cd cs) xs (=?=) y (Guard_C_Float d c x) cd cs = guardCons d c ((y =?= x) cd $! (addCs c cs)) (=?=) _ (Fail_C_Float d info) _ _ = failCons d info (=?=) (C_Float x1) (C_Float y1) _ _ = toCurry (isTrue# (x1 `eqFloat#` y1)) ( (x (y x) $## x1) (error "Show C_Char: nesting depth used") emptyCs of Choice_BinInt _ _ _ _ -> showString "chr " . shows x1 Choices_BinInt _ _ _ -> showString "chr " . shows x1 Fail_BinInt _ _ -> shows x1 Guard_BinInt _ _ _ -> shows x1 gnfBinInt -> shows (C# (curryChar2primChar gnfBinInt)) showList cs | all isPrimChar cs' = showList (map convert cs') | otherwise = showCharList cs' where cs' = map gnfCurryChar cs gnfCurryChar :: C_Char -> C_Char gnfCurryChar (CurryChar x1) = case ((\x _ _ -> x) $## x1) (error "gnfCurryChar: nesting depth used") emptyCs of Choice_BinInt _ _ _ _ -> CurryChar x1 Choices_BinInt _ _ _ -> CurryChar x1 Fail_BinInt _ _ -> CurryChar x1 Guard_BinInt _ _ _ -> CurryChar x1 gnfBinInt -> C_Char (curryChar2primChar gnfBinInt) gnfCurryChar c = c isPrimChar (C_Char _) = True isPrimChar _ = False convert (C_Char c) = C# c showCharList [] = showString "[]" showCharList (x:xs) = showChar '[' . shows x . showRest xs where showRest [] = showChar ']' showRest (y:ys) = showChar ',' . shows y . showRest ys instance Read C_Char where readsPrec d s = map readChar (readsPrec d s) where readChar (C# c, s) = (C_Char c, s) readList s = map readString (readList s) where readString (cs, s) = (map (\(C# c) -> C_Char c) cs, s) instance NonDet C_Char where choiceCons = Choice_C_Char choicesCons = Choices_C_Char failCons = Fail_C_Char guardCons = Guard_C_Char try (Choice_C_Char cd i x y) = tryChoice cd i x y try (Choices_C_Char cd i xs) = tryChoices cd i xs try (Fail_C_Char cd info) = Fail cd info try (Guard_C_Char cd c e) = Guard cd c e try x = Val x match f _ _ _ _ _ (Choice_C_Char cd i x y) = f cd i x y match _ f _ _ _ _ (Choices_C_Char cd i@(NarrowedID _ _) xs) = f cd i xs match _ _ f _ _ _ (Choices_C_Char cd i@(FreeID _ _) xs) = f cd i xs match _ _ _ _ _ _ (Choices_C_Char cd i _) = error ("Prelude.Char.match: Choices with ChoiceID " ++ (show i)) match _ _ _ f _ _ (Fail_C_Char cd info) = f cd info match _ _ _ _ f _ (Guard_C_Char cd cs e) = f cd cs e match _ _ _ _ _ f x = f x instance Generable C_Char where generate s cd = Choices_C_Char cd (freeID [1] s) [CurryChar (generate (leftSupply s) cd)] instance NormalForm C_Char where ($!!) cont x@(C_Char _) cd cs = cont x cd cs ($!!) cont (CurryChar x) cd cs = ((cont . CurryChar) $!! x) cd cs ($!!) cont (Choice_C_Char d i x y) cd cs = nfChoice cont d i x y cd cs ($!!) cont (Choices_C_Char d i xs) cd cs = nfChoices cont d i xs cd cs ($!!) cont (Guard_C_Char d c x) cd cs = guardCons d c ((cont $!! x) cd $! (addCs c cs)) ($!!) _ (Fail_C_Char d info) _ _ = failCons d info ($##) cont x@(C_Char _) cd cs = cont x cd cs ($##) cont (CurryChar x) cd cs = ((cont . CurryChar) $## x) cd cs ($##) cont (Choice_C_Char d i x y) cd cs = gnfChoice cont d i x y cd cs ($##) cont (Choices_C_Char d i xs) cd cs = gnfChoices cont d i xs cd cs ($##) cont (Guard_C_Char d c x) cd cs = guardCons d c ((cont $## x) cd $! (addCs c cs)) ($##) _ (Fail_C_Char d info) _ _ = failCons d info searchNF search cont c@(C_Char _) = cont c searchNF search cont (CurryChar x) = search (cont . CurryChar) x searchNF _ _ x = error ("Prelude.Char.searchNF: no constructor: " ++ (show x)) instance Unifiable C_Char where (=.=) (C_Char x1) (C_Char x2) cd _ | isTrue# (x1 `eqChar#` x2) = C_True | otherwise = Fail_C_Bool cd defFailInfo (=.=) (C_Char x1) (CurryChar x2) cd cs = (primChar2CurryChar x1 =:= x2) cd cs (=.=) (CurryChar x1) (C_Char x2) cd cs = (x1 =:= primChar2CurryChar x2) cd cs (=.=) (CurryChar x1) (CurryChar x2) cd cs = (x1 =:= x2) cd cs (=.=) _ _ cd _ = Fail_C_Bool cd defFailInfo (=.<=) (C_Char x1) (C_Char x2) cd _ | isTrue# (x1 `eqChar#` x2) = C_True | otherwise = Fail_C_Bool cd defFailInfo (=.<=) (C_Char x1) (CurryChar x2) cd cs = (primChar2CurryChar x1 =:<= x2) cd cs (=.<=) (CurryChar x1) (C_Char x2) cd cs = (x1 =:<= primChar2CurryChar x2) cd cs (=.<=) (CurryChar x1) (CurryChar x2) cd cs = (x1 =:<= x2) cd cs (=.<=) _ _ cd _ = Fail_C_Bool cd defFailInfo bind cd i (C_Char x) = (i :=: ChooseN 0 1) : bind cd (leftID i) (primChar2CurryChar x) bind cd i (CurryChar x) = (i :=: ChooseN 0 1) : bind cd (leftID i) x bind cd i (Choice_C_Char d j l r) = [(ConstraintChoice d j (bind cd i l) (bind cd i r))] bind cd i (Choices_C_Char d j@(FreeID _ _) xs) = bindOrNarrow cd i d j xs bind cd i (Choices_C_Char d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (bind cd i) xs))] bind _ _ c@(Choices_C_Char _ i _) = error ("Prelude.Char.bind: Choices with ChoiceID: " ++ (show c)) bind _ _ (Fail_C_Char _ info) = [Unsolvable info] bind cd i (Guard_C_Char _ cs e) = getConstrList cs ++ (bind cd i e) lazyBind cd i (C_Char x) = [i :=: ChooseN 0 1, leftID i :=: LazyBind (lazyBind cd (leftID i) (primChar2CurryChar x))] lazyBind cd i (CurryChar x) = [i :=: ChooseN 0 1, leftID i :=: LazyBind (lazyBind cd (leftID i) x)] lazyBind cd i (Choice_C_Char d j l r) = [(ConstraintChoice d j (lazyBind cd i l) (lazyBind cd i r))] lazyBind cd i (Choices_C_Char d j@(FreeID _ _) xs) = lazyBindOrNarrow cd i d j xs lazyBind cd i (Choices_C_Char d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (lazyBind cd i) xs))] lazyBind _ _ c@(Choices_C_Char _ i _) = error ("Prelude.Char.lazyBind: Choices with ChoiceID: " ++ (show c)) lazyBind _ _ (Fail_C_Char _ info) = [Unsolvable info] lazyBind cd i (Guard_C_Char _ cs e) = getConstrList cs ++ [(i :=: (LazyBind (lazyBind cd i e)))] instance Curry C_Char where (=?=) (Choice_C_Char d i x y) z cd cs = narrow d i ((x =?= z) cd cs) ((y =?= z) cd cs) (=?=) (Choices_C_Char d i xs) y cd cs = narrows cs d i (\x -> (x =?= y) cd cs) xs (=?=) (Guard_C_Char d c x) y cd cs = guardCons d c ((x =?= y) cd $! (addCs c cs)) (=?=) (Fail_C_Char d info) _ _ _ = failCons d info (=?=) z (Choice_C_Char d i x y) cd cs = narrow d i ((z =?= x) cd cs) ((z =?= y) cd cs) (=?=) y (Choices_C_Char d i xs) cd cs = narrows cs d i (\x -> (y =?= x) cd cs) xs (=?=) y (Guard_C_Char d c x) cd cs = guardCons d c ((y =?= x) cd $! (addCs c cs)) (=?=) _ (Fail_C_Char d info) _ _ = failCons d info (=?=) (C_Char x1) (C_Char y1) _ _ = toCurry (isTrue# (x1 `eqChar#` y1)) (=?=) (C_Char x1) (CurryChar y1) cd cs = ((primChar2CurryChar x1) =?= y1) cd cs (=?=) (CurryChar x1) (C_Char y1) cd cs = (x1 =?= (primChar2CurryChar y1)) cd cs (=?=) (CurryChar x1) (CurryChar y1) cd cs = (x1 =?= y1) cd cs ( (x (y BinInt primChar2CurryChar c = primint2curryint (ord# c) curryChar2primChar :: BinInt -> Char# curryChar2primChar c = chr# (curryint2primint c) -- --------------------------------------------------------------------------- -- Conversion from and to primitive Haskell types -- --------------------------------------------------------------------------- instance ConvertCurryHaskell C_Int Int where toCurry (I# i) = C_Int i fromCurry (C_Int i) = I# i fromCurry (C_CurryInt i) = I# (curryint2primint i) fromCurry _ = error "KiCS2 error: Int data with no ground term" instance ConvertCurryHaskell C_Int Integer where toCurry i = int2C_Int (fromInteger i) where int2C_Int (I# c) = C_Int c fromCurry (C_Int i) = toInteger (I# i) fromCurry (C_CurryInt i) = toInteger (I# (curryint2primint i)) fromCurry _ = error "KiCS2 error: Int data with no ground term" instance ConvertCurryHaskell C_Float Float where toCurry (F# f) = C_Float f fromCurry (C_Float f) = F# f fromCurry _ = error "KiCS2 error: Float data with no ground term" instance ConvertCurryHaskell C_Char Char where toCurry (C# c) = C_Char c fromCurry (C_Char c) = C# c fromCurry (CurryChar c) = C# (curryChar2primChar c) fromCurry _ = error "KiCS2 error: Char data with no ground term" instance (ConvertCurryHaskell ct ht) => ConvertCurryHaskell (OP_List ct) [ht] where toCurry [] = OP_List toCurry (c:cs) = OP_Cons (toCurry c) (toCurry cs) fromCurry OP_List = [] fromCurry (OP_Cons c cs) = fromCurry c : fromCurry cs fromCurry _ = error "KiCS2 error: List data with no ground term" instance ConvertCurryHaskell C_Bool Bool where toCurry True = C_True toCurry False = C_False fromCurry C_True = True fromCurry C_False = False fromCurry _ = error "KiCS2 error: Float data with no ground term" instance ConvertCurryHaskell OP_Unit () where toCurry () = OP_Unit fromCurry OP_Unit = () fromCurry _ = error "KiCS2 error: Unit data with no ground term" instance (ConvertCurryHaskell ct1 ht1, ConvertCurryHaskell ct2 ht2) => ConvertCurryHaskell (OP_Tuple2 ct1 ct2) (ht1,ht2) where toCurry (x1,x2) = OP_Tuple2 (toCurry x1) (toCurry x2) fromCurry (OP_Tuple2 x1 x2) = (fromCurry x1, fromCurry x2) fromCurry _ = error "KiCS2 error: Pair data with no ground term" instance (ConvertCurryHaskell ct1 ht1, ConvertCurryHaskell ct2 ht2, ConvertCurryHaskell ct3 ht3) => ConvertCurryHaskell (OP_Tuple3 ct1 ct2 ct3) (ht1,ht2,ht3) where toCurry (x1,x2,x3) = OP_Tuple3 (toCurry x1) (toCurry x2) (toCurry x3) fromCurry (OP_Tuple3 x1 x2 x3) = (fromCurry x1, fromCurry x2, fromCurry x3) fromCurry _ = error "KiCS2 error: Tuple3 data with no ground term occurred" instance ConvertCurryHaskell ct ht => ConvertCurryHaskell (C_Maybe ct) (Maybe ht) where toCurry Nothing = C_Nothing toCurry (Just x) = C_Just (toCurry x) fromCurry C_Nothing = Nothing fromCurry (C_Just x) = Just (fromCurry x) fromCurry _ = error "KiCS2 error: Maybe data with no ground term occurred" toCurryString :: String -> OP_List C_Char toCurryString = toCurry -- ----------------------------------------------------------------------------- -- Auxiliary operations for showing lists -- ----------------------------------------------------------------------------- showsPrec4CurryList :: Show a => Int -> OP_List a -> ShowS showsPrec4CurryList d cl = if isStandardCurryList cl then showsPrec d (clist2hlist cl) else showChar '(' . showsPrecRaw d cl . showChar ')' where isStandardCurryList OP_List = True isStandardCurryList (OP_Cons _ xs) = isStandardCurryList xs isStandardCurryList _ = False clist2hlist OP_List = [] clist2hlist (OP_Cons x xs) = x : clist2hlist xs showsPrecRaw d (Choice_OP_List cd i x y) = showsChoice d cd i x y showsPrecRaw d (Choices_OP_List cd i xs) = showsChoices d cd i xs showsPrecRaw d (Guard_OP_List cd c e) = showsGuard d cd c e showsPrecRaw d (Fail_OP_List _ _) = showChar '!' showsPrecRaw d OP_List = showString "[]" showsPrecRaw d (OP_Cons x xs) = showParen (d > 5) (showsPrec 6 x . showChar ':' . showsPrecRaw 5 xs) -- ----------------------------------------------------------------------------- -- Primitive operations: General -- ----------------------------------------------------------------------------- external_d_C_prim_show :: Show a => a -> Cover -> ConstStore -> C_String external_d_C_prim_show a _ _ = toCurry (show a) external_d_OP_eq_eq :: Curry a => a -> a -> Cover -> ConstStore -> C_Bool external_d_OP_eq_eq = (=?=) external_d_OP_lt_eq :: Curry a => a -> a -> Cover -> ConstStore -> C_Bool external_d_OP_lt_eq = ( a -> a -> Cover -> ConstStore -> C_Bool external_d_OP_eq_colon_eq = (=:=) external_d_OP_eq_colon_lt_eq :: Curry a => a -> a -> Cover -> ConstStore -> C_Bool external_d_OP_eq_colon_lt_eq = (=:<=) external_d_C_failed :: NonDet a => Cover -> ConstStore -> a external_d_C_failed cd _ = failCons cd (customFail "Call to function `failed'") external_d_C_cond :: Curry a => C_Bool -> a -> Cover -> ConstStore -> a external_d_C_cond succ a cd cs = ((\_ _ _ -> a) `d_OP_dollar_hash` succ) cd cs external_d_OP_amp :: C_Bool -> C_Bool -> Cover -> ConstStore -> C_Bool external_d_OP_amp = (&) external_d_C_ensureNotFree :: Curry a => a -> Cover -> ConstStore -> a external_d_C_ensureNotFree x cd cs = case try x of Choice d i a b -> choiceCons d i (external_d_C_ensureNotFree a cd cs) (external_d_C_ensureNotFree b cd cs) Narrowed d i xs -> choicesCons d i (map (\x -> external_d_C_ensureNotFree x cd cs) xs) Free d i xs -> narrows cs d i (\x -> external_d_C_ensureNotFree x cd cs) xs Guard d c e -> guardCons d c (external_d_C_ensureNotFree e cd $! (addCs c cs)) _ -> x external_d_OP_dollar_bang :: (NonDet a, NonDet b) => (a -> Cover -> ConstStore -> b) -> a -> Cover -> ConstStore -> b external_d_OP_dollar_bang = d_dollar_bang external_nd_OP_dollar_bang :: (NonDet a, NonDet b) => (Func a b) -> a -> IDSupply -> Cover -> ConstStore -> b external_nd_OP_dollar_bang = nd_dollar_bang external_d_OP_dollar_bang_bang :: (NormalForm a, NonDet b) => (a -> Cover -> ConstStore -> b) -> a -> Cover -> ConstStore -> b external_d_OP_dollar_bang_bang = ($!!) external_nd_OP_dollar_bang_bang :: (NormalForm a, NonDet b) => Func a b -> a -> IDSupply -> Cover -> ConstStore -> b external_nd_OP_dollar_bang_bang f x s cd cs = ((\y cd1 cs1-> nd_apply f y s cd1 cs1) $!! x) cd cs external_d_OP_dollar_hash_hash :: (NormalForm a, NonDet b) => (a -> Cover -> ConstStore -> b) -> a -> Cover -> ConstStore -> b external_d_OP_dollar_hash_hash = ($##) external_nd_OP_dollar_hash_hash :: (NormalForm a, NonDet b) => Func a b -> a -> IDSupply -> Cover -> ConstStore -> b external_nd_OP_dollar_hash_hash f x s cd cs = ((\y cd1 cs1 -> nd_apply f y s cd1 cs1) $## x) cd cs external_d_C_apply :: (a -> Cover -> ConstStore -> b) -> a -> Cover -> ConstStore -> b external_d_C_apply = d_apply external_nd_C_apply :: NonDet b => Func a b -> a -> IDSupply -> Cover -> ConstStore -> b external_nd_C_apply = nd_apply -- ----------------------------------------------------------------------------- -- Primitive operations: Characters -- ----------------------------------------------------------------------------- external_d_C_prim_ord :: C_Char -> Cover -> ConstStore -> C_Int external_d_C_prim_ord (C_Char c) _ _ = C_Int (ord# c) external_d_C_prim_ord (CurryChar c) _ _ = C_CurryInt c external_d_C_prim_chr :: C_Int -> Cover -> ConstStore -> C_Char external_d_C_prim_chr (C_Int i) _ _ = C_Char (chr# i) external_d_C_prim_chr (C_CurryInt i) _ _ = CurryChar i -- ----------------------------------------------------------------------------- -- Primitive operations: Arithmetics -- ----------------------------------------------------------------------------- external_d_OP_plus :: C_Int -> C_Int -> Cover -> ConstStore -> C_Int external_d_OP_plus (C_Int x) (C_Int y) _ _ = C_Int (x +# y) external_d_OP_plus (C_Int x) (C_CurryInt y) cd cs = C_CurryInt (((primint2curryint x) `d_OP_plus_hash` y) cd cs) external_d_OP_plus (C_CurryInt x) (C_Int y) cd cs = C_CurryInt ((x `d_OP_plus_hash` (primint2curryint y)) cd cs) external_d_OP_plus (C_CurryInt x) (C_CurryInt y) cd cs = C_CurryInt ((x `d_OP_plus_hash` y) cd cs) external_d_OP_plus x y cd cs = ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_OP_plus` b) cd2 cs2)) `d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs external_d_OP_minus :: C_Int -> C_Int -> Cover -> ConstStore -> C_Int external_d_OP_minus (C_Int x) (C_Int y) _ _ = C_Int (x -# y) external_d_OP_minus (C_Int x) (C_CurryInt y) cd cs = C_CurryInt (((primint2curryint x) `d_OP_minus_hash` y) cd cs) external_d_OP_minus (C_CurryInt x) (C_Int y) cd cs = C_CurryInt ((x `d_OP_minus_hash` (primint2curryint y)) cd cs) external_d_OP_minus (C_CurryInt x) (C_CurryInt y) cd cs = C_CurryInt ((x `d_OP_minus_hash` y) cd cs) external_d_OP_minus x y cd cs = ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_OP_minus` b) cd2 cs2 )) `d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs external_d_OP_star :: C_Int -> C_Int -> Cover -> ConstStore -> C_Int external_d_OP_star (C_Int x) (C_Int y) _ _ = C_Int (x *# y) external_d_OP_star (C_Int x) (C_CurryInt y) cd cs = C_CurryInt (((primint2curryint x) `d_OP_star_hash` y) cd cs) external_d_OP_star (C_CurryInt x) (C_Int y) cd cs = C_CurryInt ((x `d_OP_star_hash` (primint2curryint y)) cd cs) external_d_OP_star (C_CurryInt x) (C_CurryInt y) cd cs = C_CurryInt ((x `d_OP_star_hash` y) cd cs) external_d_OP_star x y cd cs = ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_OP_star` b) cd2 cs2)) `d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs external_d_C_quot :: C_Int -> C_Int -> Cover -> ConstStore -> C_Int external_d_C_quot (C_Int x) (C_Int y) cd _ | isTrue# (y ==# 0#) = Fail_C_Int cd (customFail "Division by Zero") | otherwise = C_Int (x `quotInt#` y) external_d_C_quot (C_Int x) (C_CurryInt y) cd cs = C_CurryInt (((primint2curryint x) `d_C_quotInteger` y) cd cs) external_d_C_quot (C_CurryInt x) (C_Int y) cd cs = C_CurryInt ((x `d_C_quotInteger` (primint2curryint y)) cd cs) external_d_C_quot (C_CurryInt x) (C_CurryInt y) cd cs = C_CurryInt ((x `d_C_quotInteger` y) cd cs) external_d_C_quot x y cd cs = ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_C_quot` b) cd2 cs2 )) `d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs external_d_C_rem :: C_Int -> C_Int -> Cover -> ConstStore -> C_Int external_d_C_rem (C_Int x) (C_Int y) cd _ | isTrue# (y ==# 0#) = Fail_C_Int cd (customFail "Division by Zero") | otherwise = C_Int (x `remInt#` y) external_d_C_rem (C_Int x) (C_CurryInt y) cd cs = C_CurryInt (((primint2curryint x) `d_C_remInteger` y) cd cs) external_d_C_rem (C_CurryInt x) (C_Int y) cd cs = C_CurryInt ((x `d_C_remInteger` (primint2curryint y)) cd cs) external_d_C_rem (C_CurryInt x) (C_CurryInt y) cd cs = C_CurryInt ((x `d_C_remInteger` y) cd cs) external_d_C_rem x y cd cs = ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_C_rem` b) cd2 cs2)) `d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs external_d_C_quotRem :: C_Int -> C_Int -> Cover -> ConstStore -> OP_Tuple2 C_Int C_Int external_d_C_quotRem (C_Int x) (C_Int y) cd _ | isTrue# (y ==# 0#) = Fail_OP_Tuple2 cd (customFail "Division by Zero") | otherwise = OP_Tuple2 (C_Int (x `quotInt#` y)) (C_Int (x `remInt#` y)) external_d_C_quotRem (C_Int x) (C_CurryInt y) cd cs = (mkIntTuple `d_dollar_bang` (((primint2curryint x) `d_C_quotRemInteger` y) cd cs)) cd cs external_d_C_quotRem (C_CurryInt x) (C_Int y) cd cs = (mkIntTuple `d_dollar_bang` ((x `d_C_quotRemInteger` (primint2curryint y)) cd cs)) cd cs external_d_C_quotRem (C_CurryInt x) (C_CurryInt y) cd cs = (mkIntTuple `d_dollar_bang` ((x `d_C_quotRemInteger` y) cd cs)) cd cs external_d_C_quotRem x y cd cs = ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_C_quotRem` b) cd2 cs2)) `d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs external_d_C_div :: C_Int -> C_Int -> Cover -> ConstStore -> C_Int external_d_C_div (C_Int x) (C_Int y) cd _ | isTrue# (y ==# 0#) = Fail_C_Int cd (customFail "Division by Zero") | otherwise = C_Int (x `divInt#` y) external_d_C_div (C_Int x) (C_CurryInt y) cd cs = C_CurryInt (((primint2curryint x) `d_C_divInteger` y) cd cs) external_d_C_div (C_CurryInt x) (C_Int y) cd cs = C_CurryInt ((x `d_C_divInteger` (primint2curryint y)) cd cs) external_d_C_div (C_CurryInt x) (C_CurryInt y) cd cs = C_CurryInt ((x `d_C_divInteger` y) cd cs) external_d_C_div x y cd cs = ((\a cd1 cs1-> ((\b cd2 cs2-> ((a `external_d_C_div` b) cd2 cs2)) `d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs -- PrimOp taken from GHC.Base divInt# :: Int# -> Int# -> Int# x# `divInt#` y# -- Be careful NOT to overflow if we do any additional arithmetic -- on the arguments... the following previous version of this -- code has problems with overflow: -- | (x# ># 0#) && (y# <# 0#) = ((x# -# y#) -# 1#) `quotInt#` y# -- | (x# <# 0#) && (y# ># 0#) = ((x# -# y#) +# 1#) `quotInt#` y# | isTrue# ((x# ># 0#)) && isTrue# ((y# <# 0#)) = ((x# -# 1#) `quotInt#` y#) -# 1# | isTrue# ((x# <# 0#)) && isTrue# ((y# ># 0#)) = ((x# +# 1#) `quotInt#` y#) -# 1# | otherwise = x# `quotInt#` y# external_d_C_mod :: C_Int -> C_Int -> Cover -> ConstStore -> C_Int external_d_C_mod (C_Int x) (C_Int y) cd _ | isTrue# (y ==# 0#) = Fail_C_Int cd (customFail "Division by Zero") | otherwise = C_Int (x `modInt#` y) external_d_C_mod (C_Int x) (C_CurryInt y) cd cs = C_CurryInt (((primint2curryint x) `d_C_modInteger` y) cd cs) external_d_C_mod (C_CurryInt x) (C_Int y) cd cs = C_CurryInt ((x `d_C_modInteger` (primint2curryint y)) cd cs) external_d_C_mod (C_CurryInt x) (C_CurryInt y) cd cs = C_CurryInt ((x `d_C_modInteger` y) cd cs) external_d_C_mod x y cd cs = ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_C_mod` b)) cd2 cs2) `d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs -- PrimOp taken from GHC.Base modInt# :: Int# -> Int# -> Int# x# `modInt#` y# | isTrue# ((x# ># 0#)) && isTrue# ((y# <# 0#)) || isTrue# ((x# <# 0#)) && isTrue# ((y# ># 0#)) = if isTrue# (r# /=# 0#) then r# +# y# else 0# | otherwise = r# where !r# = x# `remInt#` y# external_d_C_divMod :: C_Int -> C_Int -> Cover -> ConstStore -> OP_Tuple2 C_Int C_Int external_d_C_divMod (C_Int x) (C_Int y) cd _ | isTrue# (y ==# 0#) = Fail_OP_Tuple2 cd (customFail "Division by Zero") | otherwise = OP_Tuple2 (C_Int (x `divInt#` y)) (C_Int (x `modInt#` y)) external_d_C_divMod (C_Int x) (C_CurryInt y) cd cs = (mkIntTuple `d_OP_dollar_hash` (((primint2curryint x) `d_C_divModInteger` y) cd cs)) cd cs external_d_C_divMod (C_CurryInt x) (C_Int y) cd cs = (mkIntTuple `d_OP_dollar_hash` ((x `d_C_divModInteger` (primint2curryint y)) cd cs)) cd cs external_d_C_divMod (C_CurryInt x) (C_CurryInt y) cd cs = (mkIntTuple `d_OP_dollar_hash` ((x `d_C_divModInteger` y) cd cs)) cd cs external_d_C_divMod x y cd cs = ((\a cd1 cs1 -> ((\b cd2 cs2 -> ((a `external_d_C_divMod` b) cd2 cs2 )) `d_OP_dollar_hash` y) cd1 cs1) `d_OP_dollar_hash` x) cd cs mkIntTuple :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> OP_Tuple2 C_Int C_Int mkIntTuple (OP_Tuple2 d m) _ _ = OP_Tuple2 (C_CurryInt d) (C_CurryInt m) external_d_C_negateFloat :: C_Float -> Cover -> ConstStore -> C_Float external_d_C_negateFloat (C_Float x) _ _ = C_Float (negateFloat# x) external_d_C_negateFloat x cd cs = (external_d_C_negateFloat `d_OP_dollar_hash` x) cd cs -- ----------------------------------------------------------------------------- -- Primitive operations: IO stuff -- ----------------------------------------------------------------------------- external_d_C_return :: a -> Cover -> ConstStore -> C_IO a external_d_C_return a _ _ = fromIO (return a) external_d_C_prim_putChar :: C_Char -> Cover -> ConstStore -> C_IO OP_Unit external_d_C_prim_putChar c _ _ = toCurry putChar c external_d_C_getChar :: Cover -> ConstStore -> C_IO C_Char external_d_C_getChar _ _ = toCurry getChar external_d_C_prim_readFile :: C_String -> Cover -> ConstStore -> C_IO C_String external_d_C_prim_readFile s _ _ = toCurry readFile s -- TODO: Problem: s is not evaluated to enable lazy IO and therefore could -- be non-deterministic external_d_C_prim_writeFile :: C_String -> C_String -> Cover -> ConstStore -> C_IO OP_Unit external_d_C_prim_writeFile s1 s2 _ _ = toCurry writeFile s1 s2 -- TODO: Problem: s is not evaluated to enable lazy IO and therefore could -- be non-deterministic external_d_C_prim_appendFile :: C_String -> C_String -> Cover -> ConstStore -> C_IO OP_Unit external_d_C_prim_appendFile s1 s2 _ _ = toCurry appendFile s1 s2 external_d_OP_gt_gt_eq :: (Curry t0, Curry t1) => C_IO t0 -> (t0 -> Cover -> ConstStore -> C_IO t1) -> Cover -> ConstStore -> C_IO t1 external_d_OP_gt_gt_eq m f cd cs = C_IO $ do res <- searchIO errSupply cd cs m case res of Left err -> return (Left (traceFail ("Prelude.>>=") [show m, show f] err)) Right x -> do cs1 <- lookupGlobalCs let cs2 = combineCs cs cs1 searchIO errSupply cd cs2 (f x cd cs2) where errSupply = internalError "Prelude.(>>=): ID supply used" -- TODO: Investigate if `cs` and `cs'` are in a subset relation -- in either direction. external_nd_OP_gt_gt_eq :: (Curry t0, Curry t1) => C_IO t0 -> Func t0 (C_IO t1) -> IDSupply -> Cover -> ConstStore -> C_IO t1 external_nd_OP_gt_gt_eq m f _ _ cs = HO_C_IO $ \s cd cs' -> do let cs1 = combineCs cs' cs res <- searchIO (leftSupply s) cd cs1 m case res of Left err -> return (Left (traceFail ("Prelude.>>=") [show m, show f] err)) Right x -> do cs2 <- lookupGlobalCs let cs3 = combineCs cs1 cs2 s' = rightSupply s searchIO (leftSupply s') cd cs3 (nd_apply f x (rightSupply s') cd cs3) -- ----------------------------------------------------------------------------- -- Primitive operations: Exception handling -- ----------------------------------------------------------------------------- instance ConvertCurryHaskell C_IOError CurryException where toCurry (IOException s) = C_IOError (toCurry s) toCurry (UserException s) = C_UserError (toCurry s) toCurry (FailException s) = C_FailError (toCurry s) toCurry (NondetException s) = C_NondetError (toCurry s) fromCurry (C_IOError s) = IOException $ fromCurry s fromCurry (C_UserError s) = UserException $ fromCurry s fromCurry (C_FailError s) = FailException $ fromCurry s fromCurry (C_NondetError s) = NondetException $ fromCurry s fromCurry _ = internalError "non-deterministic IOError" external_d_C_prim_error :: C_String -> Cover -> ConstStore -> a external_d_C_prim_error s _ _ = C.throw $ UserException (fromCurry s) external_d_C_prim_ioError :: C_IOError -> Cover -> ConstStore -> C_IO a external_d_C_prim_ioError e _ _ = C.throw $ (fromCurry e :: CurryException) external_d_C_catch :: C_IO a -> (C_IOError -> Cover -> ConstStore -> C_IO a) -> Cover -> ConstStore -> C_IO a external_d_C_catch act hndl cd cs = fromIO $ C.catches (toIO errSupply1 cd cs act) (exceptionHandlers errSupply2 cd cs (nd hndl)) where errSupply1 = internalError "Prelude.catch: ID supply 1 used" errSupply2 = internalError "Prelude.catch: ID supply 2 used" external_nd_C_catch :: C_IO a -> Func C_IOError (C_IO a) -> IDSupply -> Cover -> ConstStore -> C_IO a external_nd_C_catch act hndl _ _ cs = HO_C_IO $ \s cd cs' -> do let cs1 = combineCs cs' cs res <- C.catches (toIO (leftSupply s) cd cs1 act) (exceptionHandlers (rightSupply s) cd cs1 (nd_apply hndl)) return (Right res) exceptionHandlers :: IDSupply -> Cover -> ConstStore -> (C_IOError -> IDSupply -> Cover -> ConstStore -> C_IO a) -> [C.Handler a] exceptionHandlers s cd cs hndl = [ C.Handler (\ (e :: CurryException) -> toIO (leftSupply s) cd cs (hndl (toCurry e) (rightSupply s) cd cs)) , C.Handler (\ (e :: C.IOException) -> toIO (leftSupply s) cd cs (hndl (fromIOException e) (rightSupply s) cd cs)) ] where fromIOException = toCurry . IOException . show -- ----------------------------------------------------------------------------- -- Functions on Integer and Nat added from PrimTypes -- ----------------------------------------------------------------------------- d_C_cmpNat :: Nat -> Nat -> Cover -> ConstStore -> C_Ordering d_C_cmpNat x1 x2 cd cs = case x1 of IHi -> d_C__casept_33 x2 cd cs O x5 -> d_C__casept_32 x5 x2 cd cs I x9 -> d_C__casept_30 x9 x2 cd cs Choice_Nat d i l r -> narrow d i (d_C_cmpNat l x2 cd cs) (d_C_cmpNat r x2 cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C_cmpNat z x2 cd cs) xs Guard_Nat d c e -> guardCons d c (d_C_cmpNat e x2 cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude.cmpNat" [show x1, show x2] info) _ -> failCons cd (consFail "Prelude.cmpNat" (showCons x1)) d_C_succ :: Nat -> Cover -> ConstStore -> Nat d_C_succ x1 cd cs = case x1 of IHi -> O IHi O x2 -> I x2 I x3 -> O (d_C_succ x3 cd cs) Choice_Nat d i l r -> narrow d i (d_C_succ l cd cs) (d_C_succ r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C_succ z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C_succ e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude.succ" [show x1] info) _ -> failCons cd (consFail "Prelude.succ" (showCons x1)) d_C_pred :: Nat -> Cover -> ConstStore -> Nat d_C_pred x1 cd cs = case x1 of IHi -> d_C_failed cd cs O x2 -> d_C__casept_28 x2 cd cs I x5 -> O x5 Choice_Nat d i l r -> narrow d i (d_C_pred l cd cs) (d_C_pred r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C_pred z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C_pred e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude.pred" [show x1] info) _ -> failCons cd (consFail "Prelude.pred" (showCons x1)) d_OP_plus_caret :: Nat -> Nat -> Cover -> ConstStore -> Nat d_OP_plus_caret x1 x2 cd cs = case x1 of IHi -> d_C_succ x2 cd cs O x3 -> d_C__casept_27 x3 x2 cd cs I x6 -> d_C__casept_26 x6 x2 cd cs Choice_Nat d i l r -> narrow d i (d_OP_plus_caret l x2 cd cs) (d_OP_plus_caret r x2 cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_OP_plus_caret z x2 cd cs) xs Guard_Nat d c e -> guardCons d c (d_OP_plus_caret e x2 cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude.+^" [show x1, show x2] info) _ -> failCons cd (consFail "Prelude.+^" (showCons x1)) d_OP_minus_caret :: Nat -> Nat -> Cover -> ConstStore -> BinInt d_OP_minus_caret x1 x2 cd cs = case x1 of IHi -> d_C_inc (Neg x2) cd cs O x3 -> d_C__casept_25 x3 x1 x2 cd cs I x6 -> d_C__casept_24 x6 x2 cd cs Choice_Nat d i l r -> narrow d i (d_OP_minus_caret l x2 cd cs) (d_OP_minus_caret r x2 cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_OP_minus_caret z x2 cd cs) xs Guard_Nat d c e -> guardCons d c (d_OP_minus_caret e x2 cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude.-^" [show x1, show x2] info) _ -> failCons cd (consFail "Prelude.-^" (showCons x1)) d_C_mult2 :: BinInt -> Cover -> ConstStore -> BinInt d_C_mult2 x1 cd cs = case x1 of Pos x2 -> Pos (O x2) Zero -> Zero Neg x3 -> Neg (O x3) Choice_BinInt d i l r -> narrow d i (d_C_mult2 l cd cs) (d_C_mult2 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C_mult2 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C_mult2 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude.mult2" [show x1] info) _ -> failCons cd (consFail "Prelude.mult2" (showCons x1)) d_OP_star_caret :: Nat -> Nat -> Cover -> ConstStore -> Nat d_OP_star_caret x1 x2 cd cs = case x1 of IHi -> x2 O x3 -> O (d_OP_star_caret x3 x2 cd cs) I x4 -> d_OP_plus_caret x2 (O (d_OP_star_caret x4 x2 cd cs)) cd cs Choice_Nat d i l r -> narrow d i (d_OP_star_caret l x2 cd cs) (d_OP_star_caret r x2 cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_OP_star_caret z x2 cd cs) xs Guard_Nat d c e -> guardCons d c (d_OP_star_caret e x2 cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude.*^" [show x1, show x2] info) _ -> failCons cd (consFail "Prelude.*^" (showCons x1)) d_C_div2 :: Nat -> Cover -> ConstStore -> Nat d_C_div2 x1 cd cs = case x1 of IHi -> d_C_failed cd cs O x2 -> x2 I x3 -> x3 Choice_Nat d i l r -> narrow d i (d_C_div2 l cd cs) (d_C_div2 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C_div2 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C_div2 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude.div2" [show x1] info) _ -> failCons cd (consFail "Prelude.div2" (showCons x1)) d_C_mod2 :: Nat -> Cover -> ConstStore -> BinInt d_C_mod2 x1 cd cs = case x1 of IHi -> Pos IHi O x2 -> Zero I x3 -> Pos IHi Choice_Nat d i l r -> narrow d i (d_C_mod2 l cd cs) (d_C_mod2 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C_mod2 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C_mod2 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude.mod2" [show x1] info) _ -> failCons cd (consFail "Prelude.mod2" (showCons x1)) d_C_quotRemNat :: Nat -> Nat -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C_quotRemNat x1 x2 cd cs = d_C__casept_23 x2 x1 (d_OP_eq_eq x2 IHi cd cs) cd cs d_OP_quotRemNat_dot_shift_dot_104 :: Nat -> Nat -> Cover -> ConstStore -> Nat d_OP_quotRemNat_dot_shift_dot_104 x1 x2 cd cs = case x1 of IHi -> d_C_error (toCurryString "quotRemNat.shift: IHi") cd cs O x3 -> O x2 I x4 -> I x2 Choice_Nat d i l r -> narrow d i (d_OP_quotRemNat_dot_shift_dot_104 l x2 cd cs) (d_OP_quotRemNat_dot_shift_dot_104 r x2 cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_OP_quotRemNat_dot_shift_dot_104 z x2 cd cs) xs Guard_Nat d c e -> guardCons d c (d_OP_quotRemNat_dot_shift_dot_104 e x2 cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude.quotRemNat.shift.104" [show x1 , show x2] info) _ -> failCons cd (consFail "Prelude.quotRemNat.shift.104" (showCons x1)) d_C_lteqInteger :: BinInt -> BinInt -> Cover -> ConstStore -> C_Bool d_C_lteqInteger x1 x2 cd cs = d_OP_slash_eq (d_C_cmpInteger x1 x2 cd cs) C_GT cd cs d_C_cmpInteger :: BinInt -> BinInt -> Cover -> ConstStore -> C_Ordering d_C_cmpInteger x1 x2 cd cs = case x1 of Zero -> d_C__casept_14 x2 cd cs Pos x5 -> d_C__casept_13 x5 x2 cd cs Neg x8 -> d_C__casept_12 x8 x2 cd cs Choice_BinInt d i l r -> narrow d i (d_C_cmpInteger l x2 cd cs) (d_C_cmpInteger r x2 cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C_cmpInteger z x2 cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C_cmpInteger e x2 cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude.cmpInteger" [show x1, show x2] info) _ -> failCons cd (consFail "Prelude.cmpInteger" (showCons x1)) d_C_neg :: BinInt -> Cover -> ConstStore -> BinInt d_C_neg x1 cd cs = case x1 of Zero -> Zero Pos x2 -> Neg x2 Neg x3 -> Pos x3 Choice_BinInt d i l r -> narrow d i (d_C_neg l cd cs) (d_C_neg r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C_neg z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C_neg e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude.neg" [show x1] info) _ -> failCons cd (consFail "Prelude.neg" (showCons x1)) d_C_inc :: BinInt -> Cover -> ConstStore -> BinInt d_C_inc x1 cd cs = case x1 of Zero -> Pos IHi Pos x2 -> Pos (d_C_succ x2 cd cs) Neg x3 -> d_C__casept_11 x3 cd cs Choice_BinInt d i l r -> narrow d i (d_C_inc l cd cs) (d_C_inc r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C_inc z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C_inc e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude.inc" [show x1] info) _ -> failCons cd (consFail "Prelude.inc" (showCons x1)) d_C_dec :: BinInt -> Cover -> ConstStore -> BinInt d_C_dec x1 cd cs = case x1 of Zero -> Neg IHi Pos x2 -> d_C__casept_10 x2 cd cs Neg x5 -> Neg (d_C_succ x5 cd cs) Choice_BinInt d i l r -> narrow d i (d_C_dec l cd cs) (d_C_dec r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C_dec z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C_dec e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude.dec" [show x1] info) _ -> failCons cd (consFail "Prelude.dec" (showCons x1)) d_OP_plus_hash :: BinInt -> BinInt -> Cover -> ConstStore -> BinInt d_OP_plus_hash x1 x2 cd cs = case x1 of Zero -> x2 Pos x3 -> d_C__casept_9 x3 x1 x2 cd cs Neg x6 -> d_C__casept_8 x6 x1 x2 cd cs Choice_BinInt d i l r -> narrow d i (d_OP_plus_hash l x2 cd cs) (d_OP_plus_hash r x2 cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_OP_plus_hash z x2 cd cs) xs Guard_BinInt d c e -> guardCons d c (d_OP_plus_hash e x2 cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude.+#" [show x1, show x2] info) _ -> failCons cd (consFail "Prelude.+#" (showCons x1)) d_OP_minus_hash :: BinInt -> BinInt -> Cover -> ConstStore -> BinInt d_OP_minus_hash x1 x2 cd cs = case x2 of Zero -> x1 Pos x3 -> d_OP_plus_hash x1 (Neg x3) cd cs Neg x4 -> d_OP_plus_hash x1 (Pos x4) cd cs Choice_BinInt d i l r -> narrow d i (d_OP_minus_hash x1 l cd cs) (d_OP_minus_hash x1 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_OP_minus_hash x1 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_OP_minus_hash x1 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude.-#" [show x1, show x2] info) _ -> failCons cd (consFail "Prelude.-#" (showCons x2)) d_OP_star_hash :: BinInt -> BinInt -> Cover -> ConstStore -> BinInt d_OP_star_hash x1 x2 cd cs = case x1 of Zero -> Zero Pos x3 -> d_C__casept_7 x3 x2 cd cs Neg x6 -> d_C__casept_6 x6 x2 cd cs Choice_BinInt d i l r -> narrow d i (d_OP_star_hash l x2 cd cs) (d_OP_star_hash r x2 cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_OP_star_hash z x2 cd cs) xs Guard_BinInt d c e -> guardCons d c (d_OP_star_hash e x2 cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude.*#" [show x1, show x2] info) _ -> failCons cd (consFail "Prelude.*#" (showCons x1)) d_C_quotRemInteger :: BinInt -> BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C_quotRemInteger x1 x2 cd cs = case x2 of Zero -> d_C_failed cd cs Pos x3 -> d_C__casept_5 x3 x1 cd cs Neg x9 -> d_C__casept_4 x9 x1 cd cs Choice_BinInt d i l r -> narrow d i (d_C_quotRemInteger x1 l cd cs) (d_C_quotRemInteger x1 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C_quotRemInteger x1 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C_quotRemInteger x1 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude.quotRemInteger" [show x1 , show x2] info) _ -> failCons cd (consFail "Prelude.quotRemInteger" (showCons x2)) d_OP_quotRemInteger_dot_uscore_hash_selFP2_hash_d :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_quotRemInteger_dot_uscore_hash_selFP2_hash_d x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x2 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_quotRemInteger_dot_uscore_hash_selFP2_hash_d l cd cs) (d_OP_quotRemInteger_dot_uscore_hash_selFP2_hash_d r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_quotRemInteger_dot_uscore_hash_selFP2_hash_d z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_quotRemInteger_dot_uscore_hash_selFP2_hash_d e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.quotRemInteger._#selFP2#d" [show x1] info) _ -> failCons cd (consFail "Prelude.quotRemInteger._#selFP2#d" (showCons x1)) d_OP_quotRemInteger_dot_uscore_hash_selFP3_hash_m :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_quotRemInteger_dot_uscore_hash_selFP3_hash_m x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x3 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_quotRemInteger_dot_uscore_hash_selFP3_hash_m l cd cs) (d_OP_quotRemInteger_dot_uscore_hash_selFP3_hash_m r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_quotRemInteger_dot_uscore_hash_selFP3_hash_m z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_quotRemInteger_dot_uscore_hash_selFP3_hash_m e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.quotRemInteger._#selFP3#m" [show x1] info) _ -> failCons cd (consFail "Prelude.quotRemInteger._#selFP3#m" (showCons x1)) d_OP_quotRemInteger_dot_uscore_hash_selFP5_hash_d :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_quotRemInteger_dot_uscore_hash_selFP5_hash_d x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x2 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_quotRemInteger_dot_uscore_hash_selFP5_hash_d l cd cs) (d_OP_quotRemInteger_dot_uscore_hash_selFP5_hash_d r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_quotRemInteger_dot_uscore_hash_selFP5_hash_d z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_quotRemInteger_dot_uscore_hash_selFP5_hash_d e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.quotRemInteger._#selFP5#d" [show x1] info) _ -> failCons cd (consFail "Prelude.quotRemInteger._#selFP5#d" (showCons x1)) d_OP_quotRemInteger_dot_uscore_hash_selFP6_hash_m :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_quotRemInteger_dot_uscore_hash_selFP6_hash_m x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x3 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_quotRemInteger_dot_uscore_hash_selFP6_hash_m l cd cs) (d_OP_quotRemInteger_dot_uscore_hash_selFP6_hash_m r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_quotRemInteger_dot_uscore_hash_selFP6_hash_m z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_quotRemInteger_dot_uscore_hash_selFP6_hash_m e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.quotRemInteger._#selFP6#m" [show x1] info) _ -> failCons cd (consFail "Prelude.quotRemInteger._#selFP6#m" (showCons x1)) d_OP_quotRemInteger_dot_uscore_hash_selFP8_hash_d :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_quotRemInteger_dot_uscore_hash_selFP8_hash_d x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x2 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_quotRemInteger_dot_uscore_hash_selFP8_hash_d l cd cs) (d_OP_quotRemInteger_dot_uscore_hash_selFP8_hash_d r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_quotRemInteger_dot_uscore_hash_selFP8_hash_d z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_quotRemInteger_dot_uscore_hash_selFP8_hash_d e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.quotRemInteger._#selFP8#d" [show x1] info) _ -> failCons cd (consFail "Prelude.quotRemInteger._#selFP8#d" (showCons x1)) d_OP_quotRemInteger_dot_uscore_hash_selFP9_hash_m :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_quotRemInteger_dot_uscore_hash_selFP9_hash_m x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x3 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_quotRemInteger_dot_uscore_hash_selFP9_hash_m l cd cs) (d_OP_quotRemInteger_dot_uscore_hash_selFP9_hash_m r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_quotRemInteger_dot_uscore_hash_selFP9_hash_m z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_quotRemInteger_dot_uscore_hash_selFP9_hash_m e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.quotRemInteger._#selFP9#m" [show x1] info) _ -> failCons cd (consFail "Prelude.quotRemInteger._#selFP9#m" (showCons x1)) d_C_divModInteger :: BinInt -> BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C_divModInteger x1 x2 cd cs = case x2 of Zero -> d_C_failed cd cs Pos x3 -> d_C__casept_3 x3 x1 cd cs Neg x12 -> d_C__casept_1 x12 x1 cd cs Choice_BinInt d i l r -> narrow d i (d_C_divModInteger x1 l cd cs) (d_C_divModInteger x1 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C_divModInteger x1 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C_divModInteger x1 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude.divModInteger" [show x1 , show x2] info) _ -> failCons cd (consFail "Prelude.divModInteger" (showCons x2)) d_OP_divModInteger_dot_uscore_hash_selFP11_hash_d :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_divModInteger_dot_uscore_hash_selFP11_hash_d x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x2 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_divModInteger_dot_uscore_hash_selFP11_hash_d l cd cs) (d_OP_divModInteger_dot_uscore_hash_selFP11_hash_d r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_divModInteger_dot_uscore_hash_selFP11_hash_d z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_divModInteger_dot_uscore_hash_selFP11_hash_d e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.divModInteger._#selFP11#d" [show x1] info) _ -> failCons cd (consFail "Prelude.divModInteger._#selFP11#d" (showCons x1)) d_OP_divModInteger_dot_uscore_hash_selFP12_hash_m :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_divModInteger_dot_uscore_hash_selFP12_hash_m x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x3 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_divModInteger_dot_uscore_hash_selFP12_hash_m l cd cs) (d_OP_divModInteger_dot_uscore_hash_selFP12_hash_m r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_divModInteger_dot_uscore_hash_selFP12_hash_m z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_divModInteger_dot_uscore_hash_selFP12_hash_m e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.divModInteger._#selFP12#m" [show x1] info) _ -> failCons cd (consFail "Prelude.divModInteger._#selFP12#m" (showCons x1)) d_OP_divModInteger_dot_uscore_hash_selFP14_hash_d :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_divModInteger_dot_uscore_hash_selFP14_hash_d x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x2 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_divModInteger_dot_uscore_hash_selFP14_hash_d l cd cs) (d_OP_divModInteger_dot_uscore_hash_selFP14_hash_d r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_divModInteger_dot_uscore_hash_selFP14_hash_d z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_divModInteger_dot_uscore_hash_selFP14_hash_d e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.divModInteger._#selFP14#d" [show x1] info) _ -> failCons cd (consFail "Prelude.divModInteger._#selFP14#d" (showCons x1)) d_OP_divModInteger_dot_uscore_hash_selFP15_hash_m :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_divModInteger_dot_uscore_hash_selFP15_hash_m x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x3 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_divModInteger_dot_uscore_hash_selFP15_hash_m l cd cs) (d_OP_divModInteger_dot_uscore_hash_selFP15_hash_m r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_divModInteger_dot_uscore_hash_selFP15_hash_m z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_divModInteger_dot_uscore_hash_selFP15_hash_m e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.divModInteger._#selFP15#m" [show x1] info) _ -> failCons cd (consFail "Prelude.divModInteger._#selFP15#m" (showCons x1)) d_OP_divModInteger_dot_uscore_hash_selFP17_hash_d :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_divModInteger_dot_uscore_hash_selFP17_hash_d x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x2 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_divModInteger_dot_uscore_hash_selFP17_hash_d l cd cs) (d_OP_divModInteger_dot_uscore_hash_selFP17_hash_d r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_divModInteger_dot_uscore_hash_selFP17_hash_d z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_divModInteger_dot_uscore_hash_selFP17_hash_d e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.divModInteger._#selFP17#d" [show x1] info) _ -> failCons cd (consFail "Prelude.divModInteger._#selFP17#d" (showCons x1)) d_OP_divModInteger_dot_uscore_hash_selFP18_hash_m :: OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> BinInt d_OP_divModInteger_dot_uscore_hash_selFP18_hash_m x1 cd cs = case x1 of OP_Tuple2 x2 x3 -> x3 Choice_OP_Tuple2 d i l r -> narrow d i (d_OP_divModInteger_dot_uscore_hash_selFP18_hash_m l cd cs) (d_OP_divModInteger_dot_uscore_hash_selFP18_hash_m r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_OP_divModInteger_dot_uscore_hash_selFP18_hash_m z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_OP_divModInteger_dot_uscore_hash_selFP18_hash_m e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude.divModInteger._#selFP18#m" [show x1] info) _ -> failCons cd (consFail "Prelude.divModInteger._#selFP18#m" (showCons x1)) d_C_divInteger :: BinInt -> BinInt -> Cover -> ConstStore -> BinInt d_C_divInteger x1 x2 cd cs = d_C_fst (d_C_divModInteger x1 x2 cd cs) cd cs d_C_modInteger :: BinInt -> BinInt -> Cover -> ConstStore -> BinInt d_C_modInteger x1 x2 cd cs = d_C_snd (d_C_divModInteger x1 x2 cd cs) cd cs d_C_quotInteger :: BinInt -> BinInt -> Cover -> ConstStore -> BinInt d_C_quotInteger x1 x2 cd cs = d_C_fst (d_C_quotRemInteger x1 x2 cd cs) cd cs d_C_remInteger :: BinInt -> BinInt -> Cover -> ConstStore -> BinInt d_C_remInteger x1 x2 cd cs = d_C_snd (d_C_quotRemInteger x1 x2 cd cs) cd cs d_C__casept_1 :: Nat -> BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_1 x12 x1 cd cs = case x1 of Zero -> OP_Tuple2 Zero Zero Pos x13 -> let x14 = d_C_quotRemNat x13 x12 cd cs x15 = d_OP_divModInteger_dot_uscore_hash_selFP14_hash_d x14 cd cs x16 = d_OP_divModInteger_dot_uscore_hash_selFP15_hash_m x14 cd cs x17 = OP_Tuple2 (d_C_neg (d_C_inc x15 cd cs) cd cs) (d_OP_minus_hash x16 (Pos x12) cd cs) in d_C__casept_0 x17 x15 x16 cd cs Neg x20 -> let x21 = d_C_quotRemNat x20 x12 cd cs x22 = d_OP_divModInteger_dot_uscore_hash_selFP17_hash_d x21 cd cs x23 = d_OP_divModInteger_dot_uscore_hash_selFP18_hash_m x21 cd cs in OP_Tuple2 x22 (d_C_neg x23 cd cs) Choice_BinInt d i l r -> narrow d i (d_C__casept_1 x12 l cd cs) (d_C__casept_1 x12 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_1 x12 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_1 x12 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_1" [show x12, show x1] info) _ -> failCons cd (consFail "Prelude._casept_1" (showCons x1)) d_C__casept_0 :: OP_Tuple2 BinInt BinInt -> BinInt -> BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_0 x17 x15 x16 cd cs = case x16 of Zero -> OP_Tuple2 (d_C_neg x15 cd cs) x16 Neg x18 -> x17 Pos x19 -> x17 Choice_BinInt d i l r -> narrow d i (d_C__casept_0 x17 x15 l cd cs) (d_C__casept_0 x17 x15 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_0 x17 x15 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_0 x17 x15 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_0" [show x17, show x15, show x16] info) _ -> failCons cd (consFail "Prelude._casept_0" (showCons x16)) d_C__casept_3 :: Nat -> BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_3 x3 x1 cd cs = case x1 of Zero -> OP_Tuple2 Zero Zero Pos x4 -> d_C_quotRemNat x4 x3 cd cs Neg x5 -> let x6 = d_C_quotRemNat x5 x3 cd cs x7 = d_OP_divModInteger_dot_uscore_hash_selFP11_hash_d x6 cd cs x8 = d_OP_divModInteger_dot_uscore_hash_selFP12_hash_m x6 cd cs x9 = OP_Tuple2 (d_C_neg (d_C_inc x7 cd cs) cd cs) (d_OP_minus_hash (Pos x3) x8 cd cs) in d_C__casept_2 x9 x7 x8 cd cs Choice_BinInt d i l r -> narrow d i (d_C__casept_3 x3 l cd cs) (d_C__casept_3 x3 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_3 x3 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_3 x3 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_3" [show x3, show x1] info) _ -> failCons cd (consFail "Prelude._casept_3" (showCons x1)) d_C__casept_2 :: OP_Tuple2 BinInt BinInt -> BinInt -> BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_2 x9 x7 x8 cd cs = case x8 of Zero -> OP_Tuple2 (d_C_neg x7 cd cs) x8 Neg x10 -> x9 Pos x11 -> x9 Choice_BinInt d i l r -> narrow d i (d_C__casept_2 x9 x7 l cd cs) (d_C__casept_2 x9 x7 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_2 x9 x7 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_2 x9 x7 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_2" [show x9, show x7 , show x8] info) _ -> failCons cd (consFail "Prelude._casept_2" (showCons x8)) d_C__casept_4 :: Nat -> BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_4 x9 x1 cd cs = case x1 of Zero -> OP_Tuple2 Zero Zero Pos x10 -> let x11 = d_C_quotRemNat x10 x9 cd cs x12 = d_OP_quotRemInteger_dot_uscore_hash_selFP5_hash_d x11 cd cs x13 = d_OP_quotRemInteger_dot_uscore_hash_selFP6_hash_m x11 cd cs in OP_Tuple2 (d_C_neg x12 cd cs) x13 Neg x14 -> let x15 = d_C_quotRemNat x14 x9 cd cs x16 = d_OP_quotRemInteger_dot_uscore_hash_selFP8_hash_d x15 cd cs x17 = d_OP_quotRemInteger_dot_uscore_hash_selFP9_hash_m x15 cd cs in OP_Tuple2 x16 (d_C_neg x17 cd cs) Choice_BinInt d i l r -> narrow d i (d_C__casept_4 x9 l cd cs) (d_C__casept_4 x9 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_4 x9 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_4 x9 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_4" [show x9, show x1] info) _ -> failCons cd (consFail "Prelude._casept_4" (showCons x1)) d_C__casept_5 :: Nat -> BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_5 x3 x1 cd cs = case x1 of Zero -> OP_Tuple2 Zero Zero Pos x4 -> d_C_quotRemNat x4 x3 cd cs Neg x5 -> let x6 = d_C_quotRemNat x5 x3 cd cs x7 = d_OP_quotRemInteger_dot_uscore_hash_selFP2_hash_d x6 cd cs x8 = d_OP_quotRemInteger_dot_uscore_hash_selFP3_hash_m x6 cd cs in OP_Tuple2 (d_C_neg x7 cd cs) (d_C_neg x8 cd cs) Choice_BinInt d i l r -> narrow d i (d_C__casept_5 x3 l cd cs) (d_C__casept_5 x3 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_5 x3 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_5 x3 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_5" [show x3, show x1] info) _ -> failCons cd (consFail "Prelude._casept_5" (showCons x1)) d_C__casept_6 :: Nat -> BinInt -> Cover -> ConstStore -> BinInt d_C__casept_6 x6 x2 cd cs = case x2 of Zero -> Zero Pos x7 -> Neg (d_OP_star_caret x6 x7 cd cs) Neg x8 -> Pos (d_OP_star_caret x6 x8 cd cs) Choice_BinInt d i l r -> narrow d i (d_C__casept_6 x6 l cd cs) (d_C__casept_6 x6 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_6 x6 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_6 x6 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_6" [show x6, show x2] info) _ -> failCons cd (consFail "Prelude._casept_6" (showCons x2)) d_C__casept_7 :: Nat -> BinInt -> Cover -> ConstStore -> BinInt d_C__casept_7 x3 x2 cd cs = case x2 of Zero -> Zero Pos x4 -> Pos (d_OP_star_caret x3 x4 cd cs) Neg x5 -> Neg (d_OP_star_caret x3 x5 cd cs) Choice_BinInt d i l r -> narrow d i (d_C__casept_7 x3 l cd cs) (d_C__casept_7 x3 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_7 x3 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_7 x3 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_7" [show x3, show x2] info) _ -> failCons cd (consFail "Prelude._casept_7" (showCons x2)) d_C__casept_8 :: Nat -> BinInt -> BinInt -> Cover -> ConstStore -> BinInt d_C__casept_8 x6 x1 x2 cd cs = case x2 of Zero -> x1 Pos x7 -> d_OP_minus_caret x7 x6 cd cs Neg x8 -> Neg (d_OP_plus_caret x6 x8 cd cs) Choice_BinInt d i l r -> narrow d i (d_C__casept_8 x6 x1 l cd cs) (d_C__casept_8 x6 x1 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_8 x6 x1 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_8 x6 x1 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_8" [show x6, show x1 , show x2] info) _ -> failCons cd (consFail "Prelude._casept_8" (showCons x2)) d_C__casept_9 :: Nat -> BinInt -> BinInt -> Cover -> ConstStore -> BinInt d_C__casept_9 x3 x1 x2 cd cs = case x2 of Zero -> x1 Pos x4 -> Pos (d_OP_plus_caret x3 x4 cd cs) Neg x5 -> d_OP_minus_caret x3 x5 cd cs Choice_BinInt d i l r -> narrow d i (d_C__casept_9 x3 x1 l cd cs) (d_C__casept_9 x3 x1 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_9 x3 x1 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_9 x3 x1 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_9" [show x3, show x1 , show x2] info) _ -> failCons cd (consFail "Prelude._casept_9" (showCons x2)) d_C__casept_10 :: Nat -> Cover -> ConstStore -> BinInt d_C__casept_10 x2 cd cs = case x2 of IHi -> Zero O x3 -> Pos (d_C_pred (O x3) cd cs) I x4 -> Pos (O x4) Choice_Nat d i l r -> narrow d i (d_C__casept_10 l cd cs) (d_C__casept_10 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_10 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C__casept_10 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude._casept_10" [show x2] info) _ -> failCons cd (consFail "Prelude._casept_10" (showCons x2)) d_C__casept_11 :: Nat -> Cover -> ConstStore -> BinInt d_C__casept_11 x3 cd cs = case x3 of IHi -> Zero O x4 -> Neg (d_C_pred (O x4) cd cs) I x5 -> Neg (O x5) Choice_Nat d i l r -> narrow d i (d_C__casept_11 l cd cs) (d_C__casept_11 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_11 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C__casept_11 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude._casept_11" [show x3] info) _ -> failCons cd (consFail "Prelude._casept_11" (showCons x3)) d_C__casept_12 :: Nat -> BinInt -> Cover -> ConstStore -> C_Ordering d_C__casept_12 x8 x2 cd cs = case x2 of Zero -> C_LT Pos x9 -> C_LT Neg x10 -> d_C_cmpNat x10 x8 cd cs Choice_BinInt d i l r -> narrow d i (d_C__casept_12 x8 l cd cs) (d_C__casept_12 x8 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_12 x8 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_12 x8 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_12" [show x8, show x2] info) _ -> failCons cd (consFail "Prelude._casept_12" (showCons x2)) d_C__casept_13 :: Nat -> BinInt -> Cover -> ConstStore -> C_Ordering d_C__casept_13 x5 x2 cd cs = case x2 of Zero -> C_GT Pos x6 -> d_C_cmpNat x5 x6 cd cs Neg x7 -> C_GT Choice_BinInt d i l r -> narrow d i (d_C__casept_13 x5 l cd cs) (d_C__casept_13 x5 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_13 x5 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_13 x5 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_13" [show x5, show x2] info) _ -> failCons cd (consFail "Prelude._casept_13" (showCons x2)) d_C__casept_14 :: BinInt -> Cover -> ConstStore -> C_Ordering d_C__casept_14 x2 cd cs = case x2 of Zero -> C_EQ Pos x3 -> C_LT Neg x4 -> C_GT Choice_BinInt d i l r -> narrow d i (d_C__casept_14 l cd cs) (d_C__casept_14 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_14 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_14 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_14" [show x2] info) _ -> failCons cd (consFail "Prelude._casept_14" (showCons x2)) d_C__casept_23 :: Nat -> Nat -> C_Bool -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_23 x2 x1 x3 cd cs = case x3 of C_True -> OP_Tuple2 (Pos x1) Zero C_False -> d_C__casept_22 x1 x2 (d_OP_eq_eq x1 IHi cd cs) cd cs Choice_C_Bool d i l r -> narrow d i (d_C__casept_23 x2 x1 l cd cs) (d_C__casept_23 x2 x1 r cd cs) Choices_C_Bool d i xs -> narrows cs d i (\z -> d_C__casept_23 x2 x1 z cd cs) xs Guard_C_Bool d c e -> guardCons d c (d_C__casept_23 x2 x1 e cd $! addCs c cs) Fail_C_Bool d info -> failCons d (traceFail "Prelude._casept_23" [show x2, show x1, show x3] info) _ -> failCons cd (consFail "Prelude._casept_23" (showCons x3)) d_C__casept_22 :: Nat -> Nat -> C_Bool -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_22 x1 x2 x3 cd cs = case x3 of C_True -> OP_Tuple2 Zero (Pos IHi) C_False -> d_C__casept_21 x2 x1 (d_C_otherwise cd cs) cd cs Choice_C_Bool d i l r -> narrow d i (d_C__casept_22 x1 x2 l cd cs) (d_C__casept_22 x1 x2 r cd cs) Choices_C_Bool d i xs -> narrows cs d i (\z -> d_C__casept_22 x1 x2 z cd cs) xs Guard_C_Bool d c e -> guardCons d c (d_C__casept_22 x1 x2 e cd $! addCs c cs) Fail_C_Bool d info -> failCons d (traceFail "Prelude._casept_22" [show x1, show x2, show x3] info) _ -> failCons cd (consFail "Prelude._casept_22" (showCons x3)) d_C__casept_21 :: Nat -> Nat -> C_Bool -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_21 x2 x1 x3 cd cs = case x3 of C_True -> d_C__casept_20 x2 x1 (d_C_cmpNat x1 x2 cd cs) cd cs C_False -> d_C_failed cd cs Choice_C_Bool d i l r -> narrow d i (d_C__casept_21 x2 x1 l cd cs) (d_C__casept_21 x2 x1 r cd cs) Choices_C_Bool d i xs -> narrows cs d i (\z -> d_C__casept_21 x2 x1 z cd cs) xs Guard_C_Bool d c e -> guardCons d c (d_C__casept_21 x2 x1 e cd $! addCs c cs) Fail_C_Bool d info -> failCons d (traceFail "Prelude._casept_21" [show x2, show x1, show x3] info) _ -> failCons cd (consFail "Prelude._casept_21" (showCons x3)) d_C__casept_20 :: Nat -> Nat -> C_Ordering -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_20 x2 x1 x3 cd cs = case x3 of C_EQ -> OP_Tuple2 (Pos IHi) Zero C_LT -> OP_Tuple2 Zero (Pos x1) C_GT -> d_C__casept_19 x2 x1 (d_C_quotRemNat (d_C_div2 x1 cd cs) x2 cd cs) cd cs Choice_C_Ordering d i l r -> narrow d i (d_C__casept_20 x2 x1 l cd cs) (d_C__casept_20 x2 x1 r cd cs) Choices_C_Ordering d i xs -> narrows cs d i (\z -> d_C__casept_20 x2 x1 z cd cs) xs Guard_C_Ordering d c e -> guardCons d c (d_C__casept_20 x2 x1 e cd $! addCs c cs) Fail_C_Ordering d info -> failCons d (traceFail "Prelude._casept_20" [show x2, show x1, show x3] info) _ -> failCons cd (consFail "Prelude._casept_20" (showCons x3)) d_C__casept_19 :: Nat -> Nat -> OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_19 x2 x1 x5 cd cs = case x5 of OP_Tuple2 x3 x4 -> d_C__casept_18 x4 x2 x1 x3 cd cs Choice_OP_Tuple2 d i l r -> narrow d i (d_C__casept_19 x2 x1 l cd cs) (d_C__casept_19 x2 x1 r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_C__casept_19 x2 x1 z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_C__casept_19 x2 x1 e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude._casept_19" [show x2, show x1, show x5] info) _ -> failCons cd (consFail "Prelude._casept_19" (showCons x5)) d_C__casept_18 :: BinInt -> Nat -> Nat -> BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_18 x4 x2 x1 x3 cd cs = case x3 of Neg x5 -> d_C_error (toCurryString "quotRemNat: negative quotient") cd cs Zero -> OP_Tuple2 (Pos IHi) (d_OP_minus_caret x1 x2 cd cs) Pos x6 -> d_C__casept_17 x2 x1 x6 x4 cd cs Choice_BinInt d i l r -> narrow d i (d_C__casept_18 x4 x2 x1 l cd cs) (d_C__casept_18 x4 x2 x1 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_18 x4 x2 x1 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_18 x4 x2 x1 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_18" [show x4, show x2 , show x1, show x3] info) _ -> failCons cd (consFail "Prelude._casept_18" (showCons x3)) d_C__casept_17 :: Nat -> Nat -> Nat -> BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_17 x2 x1 x6 x4 cd cs = case x4 of Neg x7 -> d_C_error (toCurryString "quotRemNat: negative remainder") cd cs Zero -> OP_Tuple2 (Pos (O x6)) (d_C_mod2 x1 cd cs) Pos x8 -> d_C__casept_16 x2 x8 x1 x6 (d_C_quotRemNat (d_OP_quotRemNat_dot_shift_dot_104 x1 x8 cd cs) x2 cd cs) cd cs Choice_BinInt d i l r -> narrow d i (d_C__casept_17 x2 x1 x6 l cd cs) (d_C__casept_17 x2 x1 x6 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_17 x2 x1 x6 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_17 x2 x1 x6 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_17" [show x2, show x1 , show x6, show x4] info) _ -> failCons cd (consFail "Prelude._casept_17" (showCons x4)) d_C__casept_16 :: Nat -> Nat -> Nat -> Nat -> OP_Tuple2 BinInt BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_16 x2 x8 x1 x6 x11 cd cs = case x11 of OP_Tuple2 x9 x10 -> d_C__casept_15 x10 x6 x9 cd cs Choice_OP_Tuple2 d i l r -> narrow d i (d_C__casept_16 x2 x8 x1 x6 l cd cs) (d_C__casept_16 x2 x8 x1 x6 r cd cs) Choices_OP_Tuple2 d i xs -> narrows cs d i (\z -> d_C__casept_16 x2 x8 x1 x6 z cd cs) xs Guard_OP_Tuple2 d c e -> guardCons d c (d_C__casept_16 x2 x8 x1 x6 e cd $! addCs c cs) Fail_OP_Tuple2 d info -> failCons d (traceFail "Prelude._casept_16" [show x2, show x8, show x1, show x6, show x11] info) _ -> failCons cd (consFail "Prelude._casept_16" (showCons x11)) d_C__casept_15 :: BinInt -> Nat -> BinInt -> Cover -> ConstStore -> OP_Tuple2 BinInt BinInt d_C__casept_15 x10 x6 x9 cd cs = case x9 of Neg x11 -> d_C_error (toCurryString "quotRemNat: negative quotient") cd cs Zero -> OP_Tuple2 (Pos (O x6)) x10 Pos x12 -> OP_Tuple2 (Pos (d_OP_plus_caret (O x6) x12 cd cs)) x10 Choice_BinInt d i l r -> narrow d i (d_C__casept_15 x10 x6 l cd cs) (d_C__casept_15 x10 x6 r cd cs) Choices_BinInt d i xs -> narrows cs d i (\z -> d_C__casept_15 x10 x6 z cd cs) xs Guard_BinInt d c e -> guardCons d c (d_C__casept_15 x10 x6 e cd $! addCs c cs) Fail_BinInt d info -> failCons d (traceFail "Prelude._casept_15" [show x10, show x6, show x9] info) _ -> failCons cd (consFail "Prelude._casept_15" (showCons x9)) d_C__casept_24 :: Nat -> Nat -> Cover -> ConstStore -> BinInt d_C__casept_24 x6 x2 cd cs = case x2 of IHi -> Pos (O x6) O x7 -> d_C_inc (d_C_mult2 (d_OP_minus_caret x6 x7 cd cs) cd cs) cd cs I x8 -> d_C_mult2 (d_OP_minus_caret x6 x8 cd cs) cd cs Choice_Nat d i l r -> narrow d i (d_C__casept_24 x6 l cd cs) (d_C__casept_24 x6 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_24 x6 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C__casept_24 x6 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude._casept_24" [show x6, show x2] info) _ -> failCons cd (consFail "Prelude._casept_24" (showCons x2)) d_C__casept_25 :: Nat -> Nat -> Nat -> Cover -> ConstStore -> BinInt d_C__casept_25 x3 x1 x2 cd cs = case x2 of IHi -> Pos (d_C_pred x1 cd cs) O x4 -> d_C_mult2 (d_OP_minus_caret x3 x4 cd cs) cd cs I x5 -> d_C_dec (d_C_mult2 (d_OP_minus_caret x3 x5 cd cs) cd cs) cd cs Choice_Nat d i l r -> narrow d i (d_C__casept_25 x3 x1 l cd cs) (d_C__casept_25 x3 x1 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_25 x3 x1 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C__casept_25 x3 x1 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude._casept_25" [show x3, show x1 , show x2] info) _ -> failCons cd (consFail "Prelude._casept_25" (showCons x2)) d_C__casept_26 :: Nat -> Nat -> Cover -> ConstStore -> Nat d_C__casept_26 x6 x2 cd cs = case x2 of IHi -> O (d_C_succ x6 cd cs) O x7 -> I (d_OP_plus_caret x6 x7 cd cs) I x8 -> O (d_OP_plus_caret (d_C_succ x6 cd cs) x8 cd cs) Choice_Nat d i l r -> narrow d i (d_C__casept_26 x6 l cd cs) (d_C__casept_26 x6 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_26 x6 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C__casept_26 x6 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude._casept_26" [show x6, show x2] info) _ -> failCons cd (consFail "Prelude._casept_26" (showCons x2)) d_C__casept_27 :: Nat -> Nat -> Cover -> ConstStore -> Nat d_C__casept_27 x3 x2 cd cs = case x2 of IHi -> I x3 O x4 -> O (d_OP_plus_caret x3 x4 cd cs) I x5 -> I (d_OP_plus_caret x3 x5 cd cs) Choice_Nat d i l r -> narrow d i (d_C__casept_27 x3 l cd cs) (d_C__casept_27 x3 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_27 x3 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C__casept_27 x3 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude._casept_27" [show x3, show x2] info) _ -> failCons cd (consFail "Prelude._casept_27" (showCons x2)) d_C__casept_28 :: Nat -> Cover -> ConstStore -> Nat d_C__casept_28 x2 cd cs = case x2 of IHi -> IHi O x3 -> I (d_C_pred x2 cd cs) I x4 -> I (O x4) Choice_Nat d i l r -> narrow d i (d_C__casept_28 l cd cs) (d_C__casept_28 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_28 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C__casept_28 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude._casept_28" [show x2] info) _ -> failCons cd (consFail "Prelude._casept_28" (showCons x2)) d_C__casept_30 :: Nat -> Nat -> Cover -> ConstStore -> C_Ordering d_C__casept_30 x9 x2 cd cs = case x2 of IHi -> C_GT O x10 -> let x11 = d_C_cmpNat x9 x10 cd cs in d_C__casept_29 x11 cd cs I x12 -> d_C_cmpNat x9 x12 cd cs Choice_Nat d i l r -> narrow d i (d_C__casept_30 x9 l cd cs) (d_C__casept_30 x9 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_30 x9 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C__casept_30 x9 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude._casept_30" [show x9, show x2] info) _ -> failCons cd (consFail "Prelude._casept_30" (showCons x2)) d_C__casept_29 :: C_Ordering -> Cover -> ConstStore -> C_Ordering d_C__casept_29 x11 cd cs = case x11 of C_EQ -> C_GT C_LT -> x11 C_GT -> x11 Choice_C_Ordering d i l r -> narrow d i (d_C__casept_29 l cd cs) (d_C__casept_29 r cd cs) Choices_C_Ordering d i xs -> narrows cs d i (\z -> d_C__casept_29 z cd cs) xs Guard_C_Ordering d c e -> guardCons d c (d_C__casept_29 e cd $! addCs c cs) Fail_C_Ordering d info -> failCons d (traceFail "Prelude._casept_29" [show x11] info) _ -> failCons cd (consFail "Prelude._casept_29" (showCons x11)) d_C__casept_32 :: Nat -> Nat -> Cover -> ConstStore -> C_Ordering d_C__casept_32 x5 x2 cd cs = case x2 of IHi -> C_GT O x6 -> d_C_cmpNat x5 x6 cd cs I x7 -> let x8 = d_C_cmpNat x5 x7 cd cs in d_C__casept_31 x8 cd cs Choice_Nat d i l r -> narrow d i (d_C__casept_32 x5 l cd cs) (d_C__casept_32 x5 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_32 x5 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C__casept_32 x5 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude._casept_32" [show x5, show x2] info) _ -> failCons cd (consFail "Prelude._casept_32" (showCons x2)) d_C__casept_31 :: C_Ordering -> Cover -> ConstStore -> C_Ordering d_C__casept_31 x8 cd cs = case x8 of C_EQ -> C_LT C_LT -> x8 C_GT -> x8 Choice_C_Ordering d i l r -> narrow d i (d_C__casept_31 l cd cs) (d_C__casept_31 r cd cs) Choices_C_Ordering d i xs -> narrows cs d i (\z -> d_C__casept_31 z cd cs) xs Guard_C_Ordering d c e -> guardCons d c (d_C__casept_31 e cd $! addCs c cs) Fail_C_Ordering d info -> failCons d (traceFail "Prelude._casept_31" [show x8] info) _ -> failCons cd (consFail "Prelude._casept_31" (showCons x8)) d_C__casept_33 :: Nat -> Cover -> ConstStore -> C_Ordering d_C__casept_33 x2 cd cs = case x2 of IHi -> C_EQ O x3 -> C_LT I x4 -> C_LT Choice_Nat d i l r -> narrow d i (d_C__casept_33 l cd cs) (d_C__casept_33 r cd cs) Choices_Nat d i xs -> narrows cs d i (\z -> d_C__casept_33 z cd cs) xs Guard_Nat d c e -> guardCons d c (d_C__casept_33 e cd $! addCs c cs) Fail_Nat d info -> failCons d (traceFail "Prelude._casept_33" [show x2] info) _ -> failCons cd (consFail "Prelude._casept_33" (showCons x2)) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/External_Profile.hs000066400000000000000000000031121305333611600250230ustar00rootroot00000000000000{-# LANGUAGE CPP, MultiParamTypeClasses #-} import System.CPUTime import System.Mem (performGC) #if __GLASGOW_HASKELL__ > 702 import GHC.Stats #endif -- #endimport - do not remove this line! instance ConvertCurryHaskell C_ProcessInfo C_ProcessInfo where toCurry = id fromCurry = id getProcessInfos :: IO [(C_ProcessInfo, Int)] #if __GLASGOW_HASKELL__ > 702 getProcessInfos = do stats <- getGCStats return [ (C_RunTime , floor (mutatorCpuSeconds stats * 1000)) , (C_ElapsedTime , floor (mutatorWallSeconds stats * 1000)) , (C_Heap , fromIntegral (maxBytesUsed stats)) , (C_Memory , fromIntegral (maxBytesUsed stats)) , (C_GarbageCollections, fromIntegral (numGcs stats)) ] #else getProcessInfos = do t <- getCPUTime return [(C_RunTime, t `div` (10^9)] #endif external_d_C_getProcessInfos :: Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_List (Curry_Prelude.OP_Tuple2 C_ProcessInfo Curry_Prelude.C_Int)) external_d_C_getProcessInfos _ _ = toCurry getProcessInfos external_d_C_garbageCollectorOff :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_garbageCollectorOff _ _ = toCurry (return () :: IO ()) -- not supported external_d_C_garbageCollectorOn :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_garbageCollectorOn _ _ = toCurry (return () :: IO ()) -- not supported external_d_C_garbageCollect :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_garbageCollect _ _ = toCurry performGC curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/External_ReadShowTerm.hs000066400000000000000000000020151305333611600257700ustar00rootroot00000000000000external_d_C_prim_showTerm :: Show a => a -> Cover -> ConstStore -> Curry_Prelude.C_String external_d_C_prim_showTerm t _ _ = toCurry (show t) external_d_C_prim_showQTerm :: Show a => a -> Cover -> ConstStore -> Curry_Prelude.C_String external_d_C_prim_showQTerm t _ _ = toCurry (show t) external_d_C_prim_readsUnqualifiedTerm :: Read a => Curry_Prelude.OP_List Curry_Prelude.C_String -> Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.OP_List (Curry_Prelude.OP_Tuple2 a Curry_Prelude.C_String) external_d_C_prim_readsUnqualifiedTerm _ = external_d_C_prim_readsQTerm external_d_C_prim_readsQTerm :: Read a => Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.OP_List (Curry_Prelude.OP_Tuple2 a Curry_Prelude.C_String) external_d_C_prim_readsQTerm s _ _ = toCurryPairs (reads (fromCurry s)) where toCurryPairs [] = Curry_Prelude.OP_List toCurryPairs ((v,s):xs) = Curry_Prelude.OP_Cons (Curry_Prelude.OP_Tuple2 v (toCurry s)) (toCurryPairs xs) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/External_SearchTree.hs000066400000000000000000000023471305333611600254610ustar00rootroot00000000000000import Control.Applicative import Control.Monad import MonadSearch import GHC.Exts (Int (I#)) instance Functor C_SearchTree where fmap = liftM instance Applicative C_SearchTree where pure = return (<*>) = ap instance Monad C_SearchTree where return = C_Value C_Fail d >>= _ = C_Fail d C_Value x >>= f = f x C_Or x y >>= f = C_Or (x >>= f) (y >>= f) Choice_C_SearchTree cd i x y >>= f = Choice_C_SearchTree cd i (x >>= f) (y >>= f) Choices_C_SearchTree cd i xs >>= f = Choices_C_SearchTree cd i (map (>>= f) xs) Guard_C_SearchTree cd cs x >>= f = Guard_C_SearchTree cd cs (x >>= f) Fail_C_SearchTree cd info >>= _ = Fail_C_SearchTree cd info instance Alternative C_SearchTree where (<|>) = mplus empty = mzero instance MonadPlus C_SearchTree where mzero = C_Fail (Curry_Prelude.C_Int -1#) mplus = C_Or instance MonadSearch C_SearchTree where splus = Choice_C_SearchTree ssum = Choices_C_SearchTree szero (I# d) _ = C_Fail (Curry_Prelude.C_Int d) constrainMSearch = Guard_C_SearchTree external_d_C_someSearchTree :: NormalForm a => a -> Cover -> ConstStore -> C_SearchTree a external_d_C_someSearchTree = encapsulatedSearch curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/External_SetFunctions.hs000066400000000000000000000006651305333611600260610ustar00rootroot00000000000000external_d_C_incDepth :: (a -> Cover -> ConstStore -> b) -> a -> Cover -> ConstStore -> b external_d_C_incDepth f v cd c = f v (incCover cd) c external_nd_C_incDepth :: (Func a b) -> a -> IDSupply -> Cover -> ConstStore -> b external_nd_C_incDepth (Func f) x s cd c = f x s (incCover cd) c external_nd_C_incDepth _ _ _ _ _ = error "External_SetFunctions.external_nd_C_incDepth: \ \functional argument no ground term" curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/External_Socket.hs000066400000000000000000000050711305333611600246610ustar00rootroot00000000000000{-# LANGUAGE MultiParamTypeClasses #-} import Control.Concurrent import Control.Monad (when) import Network import Network.Socket hiding (sClose) type C_Socket = PrimData Socket instance ConvertCurryHaskell Curry_Prelude.C_Int PortID where toCurry (PortNumber i) = toCurry (toInteger i) fromCurry i = PortNumber (fromInteger (fromCurry i)) external_d_C_prim_listenOn :: Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO C_Socket external_d_C_prim_listenOn i _ _ = toCurry listenOn i external_d_C_listenOnFresh :: Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple2 Curry_Prelude.C_Int C_Socket) external_d_C_listenOnFresh _ _ = toCurry listenOnFreshPort where listenOnFreshPort :: IO (PortID,Socket) listenOnFreshPort = do s <- listenOn (PortNumber aNY_PORT) p <- Network.socketPort s return (p,s) external_d_C_prim_socketAccept :: C_Socket -> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple2 Curry_Prelude.C_String Curry_IO.C_Handle) external_d_C_prim_socketAccept socket _ _ = toCurry (\s -> Network.accept s >>= \ (h,s,_) -> return (s,OneHandle h)) socket external_d_C_prim_waitForSocketAccept :: C_Socket -> Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.C_Maybe (Curry_Prelude.OP_Tuple2 (Curry_Prelude.OP_List Curry_Prelude.C_Char) Curry_IO.C_Handle)) external_d_C_prim_waitForSocketAccept s i _ _ = toCurry wait s i wait :: Socket -> Int -> IO (Maybe (String, CurryHandle)) wait s t = if t < 0 then Network.accept s >>= \ (h, s, _) -> return (Just (s, OneHandle h)) else do mv <- newEmptyMVar tacc <- forkIO (Network.accept s >>= \ (h, s, _) -> putMVar mv (Just (s, OneHandle h))) ttim <- forkIO (delay ((fromIntegral t :: Integer) * 1000) >> putMVar mv Nothing) res <- takeMVar mv maybe (killThread tacc) (\_ -> killThread ttim) res return res -- Like 'threadDelay', but not bounded by an 'Int' delay :: Integer -> IO () delay time = do let maxWait = min time $ toInteger (maxBound :: Int) threadDelay $ fromInteger maxWait when (maxWait /= time) $ delay (time - maxWait) external_d_C_prim_sClose :: C_Socket -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_sClose s _ _ = toCurry sClose s external_d_C_prim_connectToSocket :: Curry_Prelude.C_String -> Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_IO.C_Handle external_d_C_prim_connectToSocket str i _ _ = toCurry (\ s i -> connectTo s i >>= return . OneHandle) str i curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/External_System.hs000066400000000000000000000060631305333611600247170ustar00rootroot00000000000000{-# LANGUAGE CPP, ForeignFunctionInterface, MultiParamTypeClasses #-} import Control.Exception as C (IOException, handle) import Network.BSD (getHostName) import System.CPUTime (getCPUTime) import System.Environment (getArgs, getEnv, getProgName) import System.Exit (ExitCode (..), exitWith) import System.Process (system) #if defined(mingw32_HOST_OS) || defined(__MINGW32__) import System.Win32.Process #else import System.Posix.Process (getProcessID) #endif -- #endimport - do not remove this line! #if defined(mingw32_HOST_OS) || defined(__MINGW32__) foreign import stdcall unsafe "windows.h GetCurrentProcessId" getProcessID :: IO ProcessId #endif external_d_C_getCPUTime :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Int external_d_C_getCPUTime _ _ = toCurry (getCPUTime >>= return . (`div` (10 ^ 9))) external_d_C_getElapsedTime :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Int external_d_C_getElapsedTime _ _ = toCurry (return 0 :: IO Int) external_d_C_getArgs :: Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_List Curry_Prelude.C_String) external_d_C_getArgs _ _ = toCurry getArgs external_d_C_prim_getEnviron :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_String external_d_C_prim_getEnviron str _ _ = toCurry (handle handleIOException . getEnv) str where handleIOException :: IOException -> IO String handleIOException _ = return "" external_d_C_getHostname :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_String external_d_C_getHostname _ _ = toCurry getHostName external_d_C_getPID :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Int external_d_C_getPID _ _ = toCurry $ do pid <- getProcessID return (fromIntegral pid :: Int) external_d_C_getProgName :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_String external_d_C_getProgName _ _ = toCurry getProgName external_d_C_prim_system :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Int external_d_C_prim_system str _ _ = toCurry system str instance ConvertCurryHaskell Curry_Prelude.C_Int ExitCode where toCurry ExitSuccess = toCurry (0 :: Int) toCurry (ExitFailure i) = toCurry i fromCurry j = let i = fromCurry j :: Int in if i == 0 then ExitSuccess else ExitFailure i external_d_C_prim_exitWith :: Curry_Prelude.Curry a => Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO a external_d_C_prim_exitWith c _ _ = fromIO (exitWith (fromCurry c)) external_d_C_prim_sleep :: Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_sleep x _ _ = toCurry (\i -> system ("sleep " ++ show (i :: Int)) >> return ()) x -- TODO external_d_C_isWindows :: Cover -> ConstStore -> Curry_Prelude.C_Bool #if defined(mingw32_HOST_OS) || defined(__MINGW32__) external_d_C_isWindows _ _ = Curry_Prelude.C_True #else external_d_C_isWindows _ _ = Curry_Prelude.C_False #endif curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/External_Time.hs000066400000000000000000000050431305333611600243260ustar00rootroot00000000000000{-# LANGUAGE MultiParamTypeClasses #-} import qualified System.Time as T import qualified Data.Time.Clock as Clock import qualified Data.Time.Calendar as Cal instance ConvertCurryHaskell C_ClockTime T.ClockTime where fromCurry (C_CTime i) = T.TOD (fromCurry i) 0 toCurry (T.TOD i _) = C_CTime (toCurry i) instance ConvertCurryHaskell C_CalendarTime T.CalendarTime where fromCurry (C_CalendarTime y m d h min s tz) = T.CalendarTime (fromCurry y) (toEnum (fromCurry m - 1)) (fromCurry d) (fromCurry h) (fromCurry min) (fromCurry s) 0 undefined undefined undefined (fromCurry tz) undefined toCurry (T.CalendarTime y m d h min s _ _ _ _ tz _) = C_CalendarTime (toCurry y) (toCurry (fromEnum m + 1)) (toCurry d) (toCurry h) (toCurry min) (toCurry s) (toCurry tz) instance ConvertCurryHaskell C_ClockTime Clock.UTCTime where fromCurry ct = let (T.CalendarTime y m d h min s _ _ _ _ tz _) = T.toUTCTime (fromCurry ct) in fromIntegral tz `Clock.addUTCTime` Clock.UTCTime (Cal.fromGregorian (toInteger y) (fromEnum m + 1) d) (Clock.secondsToDiffTime (toInteger ((h * 60 + min) * 60 + s))) toCurry (Clock.UTCTime day diff) = let (y,m,d) = Cal.toGregorian day in toCurry (T.addToClockTime (T.TimeDiff 0 0 0 0 0 (round (toRational diff)) 0) (T.toClockTime (T.CalendarTime (fromIntegral y) (toEnum (m - 1)) d 0 0 0 0 undefined undefined undefined 0 undefined))) external_d_C_getClockTime :: Cover -> ConstStore -> Curry_Prelude.C_IO C_ClockTime external_d_C_getClockTime _ _ = toCurry T.getClockTime external_d_C_prim_toCalendarTime :: C_ClockTime -> Cover -> ConstStore -> Curry_Prelude.C_IO C_CalendarTime external_d_C_prim_toCalendarTime ct _ _ = toCurry T.toCalendarTime ct external_d_C_prim_toUTCTime :: C_ClockTime -> Cover -> ConstStore -> C_CalendarTime external_d_C_prim_toUTCTime ct _ _ = toCurry T.toUTCTime ct external_d_C_prim_toClockTime :: C_CalendarTime -> Cover -> ConstStore -> C_ClockTime external_d_C_prim_toClockTime ct _ _ = toCurry T.toClockTime ct curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/External_Unsafe.hs000066400000000000000000000007501305333611600246510ustar00rootroot00000000000000import System.IO.Unsafe (unsafePerformIO) import KiCS2Debug (internalError) external_d_C_unsafePerformIO :: Curry_Prelude.C_IO a -> Cover -> ConstStore -> a external_d_C_unsafePerformIO io cd cs = unsafePerformIO (toIO errSupply cd cs io) where errSupply = internalError "Unsafe.unsafePerformIO: ID supply used" external_nd_C_unsafePerformIO :: Curry_Prelude.C_IO a -> IDSupply -> Cover -> ConstStore -> a external_nd_C_unsafePerformIO io s cd cs = unsafePerformIO (toIO s cd cs io) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/External_UnsafeSearchTree.hs000066400000000000000000000030601305333611600266140ustar00rootroot00000000000000import Control.Applicative import Control.Monad import Control.Parallel.TreeSearch import System.IO import MonadSearch import GHC.Exts (Int (I#), (<#)) instance Functor C_SearchTree where fmap = liftM instance Applicative C_SearchTree where pure = return (<*>) = ap instance Monad C_SearchTree where return = C_Value C_Fail d >>= _ = C_Fail d C_Value x >>= f = f x C_Or x y >>= f = C_Or (x >>= f) (y >>= f) Choice_C_SearchTree cd i x y >>= f = Choice_C_SearchTree cd i (x >>= f) (y >>= f) Choices_C_SearchTree cd i xs >>= f = Choices_C_SearchTree cd i (map (>>= f) xs) Guard_C_SearchTree cd cs x >>= f = Guard_C_SearchTree cd cs (x >>= f) Fail_C_SearchTree cd info >>= _ = Fail_C_SearchTree cd info instance Alternative C_SearchTree where (<|>) = mplus empty = mzero instance MonadPlus C_SearchTree where mzero = C_Fail (Curry_Prelude.C_Int -1#) mplus = C_Or instance MonadSearch C_SearchTree where splus = Choice_C_SearchTree ssum = Choices_C_SearchTree szero (I# d) _ = C_Fail (Curry_Prelude.C_Int d) constrainMSearch = Guard_C_SearchTree var x _ = x external_d_C_someSearchTree :: NormalForm a => a -> Cover -> ConstStore -> C_SearchTree a external_d_C_someSearchTree = encapsulatedSearch external_d_C_lookupVarId :: Basics.NonDet a => a -> Cover -> ConstStore -> Curry_Prelude.C_Maybe (Curry_Prelude.C_Int) external_d_C_lookupVarId x _ _ = case try x of Free _ i _ -> Curry_Prelude.C_Just (Basics.toCurry (Basics.getKey i)) _ -> Curry_Prelude.C_Nothing curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/External_ValueSequence.hs000066400000000000000000000105121305333611600261720ustar00rootroot00000000000000{-# LANGUAGE CPP #-} import GHC.Exts (Int (I#),(<#)) #if __GLASGOW_HASKELL__ > 706 import GHC.Exts (isTrue#) #endif -- #endimport - do not remove this line! #if !(__GLASGOW_HASKELL__ > 706) isTrue# :: Bool -> Bool {-# INLINE isTrue# #-} isTrue# x = x #endif external_d_OP_bar_plus_plus_bar :: Curry_Prelude.Curry a => C_ValueSequence a -> C_ValueSequence a -> Cover -> ConstStore -> C_ValueSequence a external_d_OP_bar_plus_plus_bar l1 l2 _ _ = l1 |++| l2 data C_ValueSequence a = EmptyVS | Values (Curry_Prelude.OP_List a) | FailVS (Curry_Prelude.C_Int) | Choice_VS Cover ID (C_ValueSequence a) (C_ValueSequence a) | Choices_VS Cover ID [C_ValueSequence a] | Guard_VS Cover Constraints (C_ValueSequence a) instance Curry_Prelude.Curry (C_ValueSequence a) where instance Show (C_ValueSequence a) where showsPrec = error "SearchTree: ValueSequence: showsPrec" instance Read (C_ValueSequence a) where readsPrec = error "SearchTree: ValueSequence: readsPrec" instance Unifiable (C_ValueSequence a) where (=.=) = error "SearchTree: ValueSequence: (=.=)" (=.<=) = error "SearchTree: ValueSequence: (=.<=)" bind = error "SearchTree: ValueSequence: bind" lazyBind = error "SearchTree: ValueSequence: lazyBind" instance NonDet (C_ValueSequence a) where choiceCons = Choice_VS choicesCons = Choices_VS guardCons = Guard_VS failCons = error "SearchTree: ValueSequence: failCons" try = error "SearchTree: ValueSequence: try" match = error "SearchTree: ValueSequence: match" instance Generable (C_ValueSequence a) where generate = error "SearchTree: ValueSequence: generate" instance NormalForm (C_ValueSequence a) where ($!!) = error "SearchTree: ValueSequence: ($!!)" ($##) = error "SearchTree: ValueSequence: ($##)" searchNF _ _ _ = error "SearchTree: ValueSequence: searchNF" external_d_C_emptyVS :: Cover -> ConstStore -> C_ValueSequence a external_d_C_emptyVS _ _ = EmptyVS external_d_C_addVS :: a -> C_ValueSequence a -> Cover -> ConstStore -> C_ValueSequence a external_d_C_addVS x vs _ _ = Values (Curry_Prelude.OP_Cons x (getValues vs)) external_d_C_failVS :: Curry_Prelude.C_Int -> Cover -> ConstStore -> C_ValueSequence a external_d_C_failVS d@(Curry_Prelude.C_Int d') (I# cd) _ | isTrue# (d' <# cd) = FailVS d | otherwise = Values (Curry_Prelude.OP_List) external_d_C_vsToList :: C_ValueSequence a -> Cover -> ConstStore -> Curry_Prelude.OP_List a external_d_C_vsToList (Values xs) _ _ = xs external_d_C_vsToList (FailVS (Curry_Prelude.C_Int d)) _ _ = failCons (I# d) defFailInfo external_d_C_vsToList (Choice_VS d i x y) cd cs = choiceCons d i (external_d_C_vsToList x cd cs) (external_d_C_vsToList y cd cs) external_d_C_vsToList (Choices_VS d i xs) cd cs = choicesCons d i (map (\x -> external_d_C_vsToList x cd cs) xs ) external_d_C_vsToList (Guard_VS d c x) cd cs = guardCons d c (external_d_C_vsToList x cd cs) (|++|) :: Curry_Prelude.Curry a => C_ValueSequence a -> C_ValueSequence a -> C_ValueSequence a EmptyVS |++| vs = vs Values xs |++| vs = Values (Curry_Prelude.d_OP_plus_plus xs (getValues vs) (error "ExternalSearchTree: |++| - nesting depth used") emptyCs) FailVS d |++| vs = failGreatest d vs Choice_VS cd i x y |++| vs = choiceCons cd i (x |++| vs) (y |++| vs) Choices_VS cd i xs |++| vs = choicesCons cd i (map (|++| vs) xs) Guard_VS cd cs xs |++| vs = guardCons cd cs (xs |++| vs) getValues EmptyVS = Curry_Prelude.OP_List getValues (FailVS _) = Curry_Prelude.OP_List getValues (Values xs) = xs getValues (Choice_VS cd i x y) = choiceCons cd i (getValues x) (getValues y) getValues (Choices_VS cd i xs) = choicesCons cd i (map getValues xs) getValues (Guard_VS cd cs x) = guardCons cd cs (getValues x) failGreatest d EmptyVS = FailVS d failGreatest d (FailVS d2) = FailVS (Curry_Prelude.d_C_max d d2 (error "ExternalSearchTree: failGreatest - nesting depth used") emptyCs) failGreatest _ vs@(Values _) = vs failGreatest d (Choice_VS cd i x y) = choiceCons cd i (failGreatest d x) (failGreatest d y) failGreatest d (Choices_VS cd i xs) = choicesCons cd i (map (failGreatest d) xs) failGreatest d (Guard_VS cd cs x) = guardCons cd cs (failGreatest d x) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/FileGoodies.curry000066400000000000000000000077421305333611600245210ustar00rootroot00000000000000------------------------------------------------------------------------------ --- A collection of useful operations when dealing with files. --- --- @author Michael Hanus, Bernd Brassel --- @version June 2009 --- @category general ------------------------------------------------------------------------------ module FileGoodies(separatorChar,pathSeparatorChar,suffixSeparatorChar, isAbsolute,dirName,baseName,splitDirectoryBaseName, stripSuffix,fileSuffix,splitBaseName,splitPath, lookupFileInPath,getFileInPath) where import Directory import List(intersperse) --- The character for separating hierarchies in file names. --- On UNIX systems the value is '/'. separatorChar :: Char separatorChar = '/' --- The character for separating names in path expressions. --- On UNIX systems the value is ':'. pathSeparatorChar :: Char pathSeparatorChar = ':' --- The character for separating suffixes in file names. --- On UNIX systems the value is '.'. suffixSeparatorChar :: Char suffixSeparatorChar = '.' --- Is the argument an absolute name? isAbsolute :: String -> Bool isAbsolute (c:_) = c == separatorChar isAbsolute [] = False --- Extracts the directoy prefix of a given (Unix) file name. --- Returns "." if there is no prefix. dirName :: String -> String dirName name = fst (splitDirectoryBaseName name) --- Extracts the base name without directoy prefix of a given (Unix) file name. baseName :: String -> String baseName name = snd (splitDirectoryBaseName name) --- Splits a (Unix) file name into the directory prefix and the base name. --- The directory prefix is "." if there is no real prefix in the name. splitDirectoryBaseName :: String -> (String,String) splitDirectoryBaseName name = let (rbase,rdir) = break (==separatorChar) (reverse name) in if null rdir then (".",reverse rbase) else (reverse (tail rdir), reverse rbase) --- Strips a suffix (the last suffix starting with a dot) from a file name. stripSuffix :: String -> String stripSuffix = fst . splitBaseName --- Yields the suffix (the last suffix starting with a dot) from given file name. fileSuffix :: String -> String fileSuffix = snd . splitBaseName --- Splits a file name into prefix and suffix (the last suffix starting with a dot --- and the rest). splitBaseName :: String -> (String,String) splitBaseName name = let (rsuffix,rbase) = break (==suffixSeparatorChar) (reverse name) in if null rbase || elem separatorChar rsuffix then (name,"") else (reverse (tail rbase),reverse rsuffix) --- Splits a path string into list of directory names. splitPath :: String -> [String] splitPath [] = [] splitPath (x:xs) = let (ys,zs) = break (==pathSeparatorChar) (x:xs) in if null zs then [ys] else ys : splitPath (tail zs) --- Looks up the first file with a possible suffix in a list of directories. --- Returns Nothing if such a file does not exist. lookupFileInPath :: String -> [String] -> [String] -> IO (Maybe String) lookupFileInPath file suffixes path = if isAbsolute file then lookupFirstFileWithSuffix file suffixes else lookupFirstFile path where lookupFirstFile [] = return Nothing lookupFirstFile (dir:dirs) = do mbfile <- lookupFirstFileWithSuffix (dir++separatorChar:file) suffixes maybe (lookupFirstFile dirs) (return . Just) mbfile lookupFirstFileWithSuffix _ [] = return Nothing lookupFirstFileWithSuffix f (suf:sufs) = do let fsuf = f++suf exfile <- doesFileExist fsuf if exfile then return (Just fsuf) else lookupFirstFileWithSuffix f sufs --- Gets the first file with a possible suffix in a list of directories. --- An error message is delivered if there is no such file. getFileInPath :: String -> [String] -> [String] -> IO String getFileInPath file suffixes path = do mbfile <- lookupFileInPath file suffixes path maybe (error $ "File "++file++" not found in path "++ concat (intersperse [pathSeparatorChar] path)) return mbfile curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/FilePath.curry000066400000000000000000000721101305333611600240130ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library is a direct port of the Haskell library System.FilePath --- of Neil Mitchell. --- --- @author Bjoern Peemoeller --- @version November 2011 --- @category general ------------------------------------------------------------------------------ -- -- Some short examples: -- -- You are given a C file, you want to figure out the corresponding object (.o) file: -- -- @'replaceExtension' file \"o\"@ -- -- Haskell module Main imports Test, you have the file named main: -- -- @['replaceFileName' path_to_main \"Test\" '<.>' ext | ext <- [\"hs\",\"lhs\"] ]@ -- -- You want to download a file from the web and save it to disk: -- -- @do let file = 'makeValid' url -- System.IO.createDirectoryIfMissing True ('takeDirectory' file)@ -- -- You want to compile a Haskell file, but put the hi file under \"interface\" -- -- @'takeDirectory' file '' \"interface\" '' ('takeFileName' file \`replaceExtension\` \"hi\"@) -- -- The examples in code format descibed by each function are used to generate -- tests, and should give clear semantics for the functions. ----------------------------------------------------------------------------- module FilePath ( -- * Separator predicates FilePath, pathSeparator, pathSeparators, isPathSeparator, searchPathSeparator, isSearchPathSeparator, extSeparator, isExtSeparator, -- * Path methods (environment $PATH) splitSearchPath, getSearchPath, -- * Extension methods splitExtension, takeExtension, replaceExtension, dropExtension, addExtension, hasExtension, (<.>), splitExtensions, dropExtensions, takeExtensions, -- * Drive methods splitDrive, joinDrive, takeDrive, hasDrive, dropDrive, isDrive, -- * Operations on a FilePath, as a list of directories splitFileName, takeFileName, replaceFileName, dropFileName, takeBaseName, replaceBaseName, takeDirectory, replaceDirectory, combine, (), splitPath, joinPath, splitDirectories, -- * Low level FilePath operators hasTrailingPathSeparator, addTrailingPathSeparator, dropTrailingPathSeparator, -- * File name manipulators normalise, equalFilePath, makeRelative, isRelative, isAbsolute, isValid, makeValid ) where import Char (toLower, toUpper) import List (isPrefixOf, init, last) import Maybe (isJust, fromJust) import System (getEnviron, isPosix, isWindows) infixr 7 <.> infixr 5 type FilePath = String --------------------------------------------------------------------- -- The basic functions -- | The character that separates directories. In the case where more than -- one character is possible, 'pathSeparator' is the \'ideal\' one. -- -- > Windows: pathSeparator == '\\' -- > Posix: pathSeparator == '/' -- > isPathSeparator pathSeparator pathSeparator :: Char pathSeparator = if isWindows then '\\' else '/' -- | The list of all possible separators. -- -- > Windows: pathSeparators == ['\\', '/'] -- > Posix: pathSeparators == ['/'] -- > pathSeparator `elem` pathSeparators pathSeparators :: [Char] pathSeparators = if isWindows then "\\/" else "/" -- | Rather than using @(== 'pathSeparator')@, use this. Test if something -- is a path separator. -- -- > isPathSeparator a == (a `elem` pathSeparators) isPathSeparator :: Char -> Bool isPathSeparator = (`elem` pathSeparators) -- | The character that is used to separate the entries in the $PATH -- environment variable. -- -- > Windows: searchPathSeparator == ';' -- > Posix: searchPathSeparator == ':' searchPathSeparator :: Char searchPathSeparator = if isWindows then ';' else ':' -- | Is the character a file separator? -- -- > isSearchPathSeparator a == (a == searchPathSeparator) isSearchPathSeparator :: Char -> Bool isSearchPathSeparator = (== searchPathSeparator) -- | File extension character -- -- > extSeparator == '.' extSeparator :: Char extSeparator = '.' -- | Is the character an extension character? -- -- > isExtSeparator a == (a == extSeparator) isExtSeparator :: Char -> Bool isExtSeparator = (== extSeparator) --------------------------------------------------------------------- -- Path methods (environment $PATH) -- | Take a string, split it on the 'searchPathSeparator' character. -- -- Follows the recommendations in -- -- -- > Posix: splitSearchPath "File1:File2:File3" == ["File1","File2","File3"] -- > Posix: splitSearchPath "File1::File2:File3" == ["File1",".","File2","File3"] -- > Windows: splitSearchPath "File1;File2;File3" == ["File1","File2","File3"] -- > Windows: splitSearchPath "File1;;File2;File3" == ["File1","File2","File3"] splitSearchPath :: String -> [FilePath] splitSearchPath = f where f xs = case break isSearchPathSeparator xs of (pre, [] ) -> g pre (pre, _:post) -> g pre ++ f post g [] = ["." | isPosix] g x@(_:_) = [x] -- | Get a list of filepaths in the $PATH. getSearchPath :: IO [FilePath] getSearchPath = getEnviron "PATH" >>= return . splitSearchPath --------------------------------------------------------------------- -- Extension methods -- | Split on the extension. 'addExtension' is the inverse. -- -- > uncurry (++) (splitExtension x) == x -- > uncurry addExtension (splitExtension x) == x -- > splitExtension "file.txt" == ("file",".txt") -- > splitExtension "file" == ("file","") -- > splitExtension "file/file.txt" == ("file/file",".txt") -- > splitExtension "file.txt/boris" == ("file.txt/boris","") -- > splitExtension "file.txt/boris.ext" == ("file.txt/boris",".ext") -- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred") -- > splitExtension "file/path.txt/" == ("file/path.txt/","") splitExtension :: FilePath -> (String, String) splitExtension x = case d of [] -> (x,"") (y:ys) -> (a ++ reverse ys, y : reverse c) where (a,b) = splitFileName_ x (c,d) = break isExtSeparator $ reverse b -- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise. -- -- > takeExtension x == snd (splitExtension x) -- > Valid x => takeExtension (addExtension x "ext") == ".ext" -- > Valid x => takeExtension (replaceExtension x "ext") == ".ext" takeExtension :: FilePath -> String takeExtension = snd . splitExtension -- | Set the extension of a file, overwriting one if already present. -- -- > replaceExtension "file.txt" ".bob" == "file.bob" -- > replaceExtension "file.txt" "bob" == "file.bob" -- > replaceExtension "file" ".bob" == "file.bob" -- > replaceExtension "file.txt" "" == "file" -- > replaceExtension "file.fred.bob" "txt" == "file.fred.txt" replaceExtension :: FilePath -> String -> FilePath replaceExtension x y = dropExtension x <.> y -- | Alias to 'addExtension', for people who like that sort of thing. (<.>) :: FilePath -> String -> FilePath (<.>) = addExtension -- | Remove last extension, and the \".\" preceding it. -- -- > dropExtension x == fst (splitExtension x) dropExtension :: FilePath -> FilePath dropExtension = fst . splitExtension -- | Add an extension, even if there is already one there. -- E.g. @addExtension \"foo.txt\" \"bat\" -> \"foo.txt.bat\"@. -- -- > addExtension "file.txt" "bib" == "file.txt.bib" -- > addExtension "file." ".bib" == "file..bib" -- > addExtension "file" ".bib" == "file.bib" -- > addExtension "/" "x" == "/.x" -- > Valid x => takeFileName (addExtension (addTrailingPathSeparator x) "ext") == ".ext" -- > Windows: addExtension "\\\\share" ".txt" == "\\\\share\\.txt" addExtension :: FilePath -> String -> FilePath addExtension file [] = file addExtension file xs@(x:_) = joinDrive a res where res = if isExtSeparator x then b ++ xs else b ++ [extSeparator] ++ xs (a,b) = splitDrive file -- | Does the given filename have an extension? -- -- > null (takeExtension x) == not (hasExtension x) hasExtension :: FilePath -> Bool hasExtension = any isExtSeparator . takeFileName -- | Split on all extensions -- -- > uncurry (++) (splitExtensions x) == x -- > uncurry addExtension (splitExtensions x) == x -- > splitExtensions "file.tar.gz" == ("file",".tar.gz") splitExtensions :: FilePath -> (FilePath, String) splitExtensions x = (a ++ c, d) where (a,b) = splitFileName_ x (c,d) = break isExtSeparator b -- | Drop all extensions -- -- > not $ hasExtension (dropExtensions x) dropExtensions :: FilePath -> FilePath dropExtensions = fst . splitExtensions -- | Get all extensions -- -- > takeExtensions "file.tar.gz" == ".tar.gz" takeExtensions :: FilePath -> String takeExtensions = snd . splitExtensions --------------------------------------------------------------------- -- Drive methods -- | Is the given character a valid drive letter? -- only a-z and A-Z are letters, not isAlpha which is more unicodey isLetter :: Char -> Bool isLetter x = (x >= 'a' && x <= 'z') || (x >= 'A' && x <= 'Z') -- | Split a path into a drive and a path. -- On Unix, \/ is a Drive. -- -- > uncurry (++) (splitDrive x) == x -- > Windows: splitDrive "file" == ("","file") -- > Windows: splitDrive "c:/file" == ("c:/","file") -- > Windows: splitDrive "c:\\file" == ("c:\\","file") -- > Windows: splitDrive "\\\\shared\\test" == ("\\\\shared\\","test") -- > Windows: splitDrive "\\\\shared" == ("\\\\shared","") -- > Windows: splitDrive "\\\\?\\UNC\\shared\\file" == ("\\\\?\\UNC\\shared\\","file") -- > Windows: splitDrive "\\\\?\\UNCshared\\file" == ("\\\\?\\","UNCshared\\file") -- > Windows: splitDrive "\\\\?\\d:\\file" == ("\\\\?\\d:\\","file") -- > Windows: splitDrive "/d" == ("","/d") -- > Posix: splitDrive "/test" == ("/","test") -- > Posix: splitDrive "//test" == ("//","test") -- > Posix: splitDrive "test/file" == ("","test/file") -- > Posix: splitDrive "file" == ("","file") splitDrive :: FilePath -> (FilePath, FilePath) splitDrive x | isPosix = span (== '/') x | isJust dl = fromJust dl | isJust unc = fromJust unc | isJust shr = fromJust shr | otherwise = ("",x) where dl = readDriveLetter x unc = readDriveUNC x shr = readDriveShare x addSlash :: FilePath -> FilePath -> (FilePath, FilePath) addSlash a xs = (a++c,d) where (c,d) = span isPathSeparator xs -- http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp -- "\\?\D:\" or "\\?\UNC\\" -- a is "\\?\" readDriveUNC :: FilePath -> Maybe (FilePath, FilePath) readDriveUNC path = case path of (s1:s2:'?':s3:xs) -> if all isPathSeparator [s1,s2,s3] then let rdl = case readDriveLetter xs of Just (a,b) -> Just (s1:s2:'?':s3:a,b) Nothing -> Nothing in case map toUpper xs of ('U':'N':'C':s4:_) -> if isPathSeparator s4 then let (a,b) = readDriveShareName (drop 4 xs) in Just (s1:s2:'?':s3:take 4 xs ++ a, b) else rdl _ -> rdl else Nothing _ -> Nothing {- c:\ -} readDriveLetter :: String -> Maybe (FilePath, FilePath) readDriveLetter path = case path of (x:':':y:xs) -> if isLetter x && isPathSeparator y then Just $ addSlash [x,':'] (y:xs) else if isLetter x then Just ([x,':'], (y:xs)) else Nothing (x:':':xs) -> if isLetter x then Just ([x,':'], xs) else Nothing _ -> Nothing {- \\sharename\ -} readDriveShare :: String -> Maybe (FilePath, FilePath) readDriveShare path = case path of (s1:s2:xs) -> if isPathSeparator s1 && isPathSeparator s2 then let (a,b) = readDriveShareName xs in Just (s1:s2:a,b) else Nothing _ -> Nothing {- assume you have already seen \\ -} {- share\bob -> "share","\","bob" -} readDriveShareName :: String -> (FilePath, FilePath) readDriveShareName name = addSlash a b where (a,b) = break isPathSeparator name -- | Join a drive and the rest of the path. -- -- > uncurry joinDrive (splitDrive x) == x -- > Windows: joinDrive "C:" "foo" == "C:foo" -- > Windows: joinDrive "C:\\" "bar" == "C:\\bar" -- > Windows: joinDrive "\\\\share" "foo" == "\\\\share\\foo" -- > Windows: joinDrive "/:" "foo" == "/:\\foo" joinDrive :: FilePath -> FilePath -> FilePath joinDrive a b | isPosix = a ++ b | null a = b | null b = a | isPathSeparator (last a) = a ++ b | otherwise = case a of [a1,':'] -> if isLetter a1 then a ++ b else a ++ [pathSeparator] ++ b _ -> a ++ [pathSeparator] ++ b -- | Get the drive from a filepath. -- -- > takeDrive x == fst (splitDrive x) takeDrive :: FilePath -> FilePath takeDrive = fst . splitDrive -- | Delete the drive, if it exists. -- -- > dropDrive x == snd (splitDrive x) dropDrive :: FilePath -> FilePath dropDrive = snd . splitDrive -- | Does a path have a drive. -- -- > not (hasDrive x) == null (takeDrive x) hasDrive :: FilePath -> Bool hasDrive = not . null . takeDrive -- | Is an element a drive isDrive :: FilePath -> Bool isDrive = null . dropDrive --------------------------------------------------------------------- -- Operations on a filepath, as a list of directories -- | Split a filename into directory and file. 'combine' is the inverse. -- -- > Valid x => uncurry () (splitFileName x) == x || fst (splitFileName x) == "./" -- > Valid x => isValid (fst (splitFileName x)) -- > splitFileName "file/bob.txt" == ("file/", "bob.txt") -- > splitFileName "file/" == ("file/", "") -- > splitFileName "bob" == ("./", "bob") -- > Posix: splitFileName "/" == ("/","") -- > Windows: splitFileName "c:" == ("c:","") splitFileName :: FilePath -> (String, String) splitFileName x = (if null dir then "./" else dir, name) where (dir, name) = splitFileName_ x -- version of splitFileName where, if the FilePath has no directory -- component, the returned directory is "" rather than "./". This -- is used in cases where we are going to combine the returned -- directory to make a valid FilePath, and having a "./" appear would -- look strange and upset simple equality properties. See -- e.g. replaceFileName. splitFileName_ :: FilePath -> (String, String) splitFileName_ x = (c ++ reverse b, reverse a) where (a,b) = break isPathSeparator $ reverse d (c,d) = splitDrive x -- | Set the filename. -- -- > Valid x => replaceFileName x (takeFileName x) == x replaceFileName :: FilePath -> String -> FilePath replaceFileName x y = a y where (a,_) = splitFileName_ x -- | Drop the filename. -- -- > dropFileName x == fst (splitFileName x) dropFileName :: FilePath -> FilePath dropFileName = fst . splitFileName -- | Get the file name. -- -- > takeFileName "test/" == "" -- > takeFileName x `isSuffixOf` x -- > takeFileName x == snd (splitFileName x) -- > Valid x => takeFileName (replaceFileName x "fred") == "fred" -- > Valid x => takeFileName (x "fred") == "fred" -- > Valid x => isRelative (takeFileName x) takeFileName :: FilePath -> FilePath takeFileName = snd . splitFileName -- | Get the base name, without an extension or path. -- -- > takeBaseName "file/test.txt" == "test" -- > takeBaseName "dave.ext" == "dave" -- > takeBaseName "" == "" -- > takeBaseName "test" == "test" -- > takeBaseName (addTrailingPathSeparator x) == "" -- > takeBaseName "file/file.tar.gz" == "file.tar" takeBaseName :: FilePath -> String takeBaseName = dropExtension . takeFileName -- | Set the base name. -- -- > replaceBaseName "file/test.txt" "bob" == "file/bob.txt" -- > replaceBaseName "fred" "bill" == "bill" -- > replaceBaseName "/dave/fred/bob.gz.tar" "new" == "/dave/fred/new.tar" -- > Valid x => replaceBaseName x (takeBaseName x) == x replaceBaseName :: FilePath -> String -> FilePath replaceBaseName pth nam = combineAlways a (nam <.> ext) where (a,b) = splitFileName_ pth ext = takeExtension b -- | Is an item either a directory or the last character a path separator? -- -- > hasTrailingPathSeparator "test" == False -- > hasTrailingPathSeparator "test/" == True hasTrailingPathSeparator :: FilePath -> Bool hasTrailingPathSeparator [] = False hasTrailingPathSeparator x@(_:_) = isPathSeparator (last x) -- | Add a trailing file path separator if one is not already present. -- -- > hasTrailingPathSeparator (addTrailingPathSeparator x) -- > hasTrailingPathSeparator x ==> addTrailingPathSeparator x == x -- > Posix: addTrailingPathSeparator "test/rest" == "test/rest/" addTrailingPathSeparator :: FilePath -> FilePath addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pathSeparator] -- | Remove any trailing path separators -- -- > dropTrailingPathSeparator "file/test/" == "file/test" -- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x -- > Posix: dropTrailingPathSeparator "/" == "/" -- > Windows: dropTrailingPathSeparator "\\" == "\\" dropTrailingPathSeparator :: FilePath -> FilePath dropTrailingPathSeparator x = if hasTrailingPathSeparator x && not (isDrive x) then let x' = reverse $ dropWhile isPathSeparator $ reverse x in if null x' then [pathSeparator] else x' else x -- | Get the directory name, move up one level. -- -- > takeDirectory x `isPrefixOf` x || takeDirectory x == "." -- > takeDirectory "foo" == "." -- > takeDirectory "/foo/bar/baz" == "/foo/bar" -- > takeDirectory "/foo/bar/baz/" == "/foo/bar/baz" -- > takeDirectory "foo/bar/baz" == "foo/bar" -- > Windows: takeDirectory "foo\\bar" == "foo" -- > Windows: takeDirectory "foo\\bar\\\\" == "foo\\bar" -- > Windows: takeDirectory "C:\\" == "C:\\" takeDirectory :: FilePath -> FilePath takeDirectory x = if isDrive file then file else if null res && not (null file) then file else res where res = reverse $ dropWhile isPathSeparator $ reverse file file = dropFileName x _ = isPrefixOf x -- warning suppression -- | Set the directory, keeping the filename the same. -- -- > Valid x => replaceDirectory x (takeDirectory x) `equalFilePath` x replaceDirectory :: FilePath -> String -> FilePath replaceDirectory x dir = combineAlways dir (takeFileName x) -- | Combine two paths, if the second path 'isAbsolute', then it returns the second. -- -- > Valid x => combine (takeDirectory x) (takeFileName x) `equalFilePath` x -- > Posix: combine "/" "test" == "/test" -- > Posix: combine "home" "bob" == "home/bob" -- > Windows: combine "home" "bob" == "home\\bob" -- > Windows: combine "home" "/bob" == "/bob" combine :: FilePath -> FilePath -> FilePath combine a b | hasDrive b || (not (null b) && isPathSeparator (head b)) = b | otherwise = combineAlways a b -- | Combine two paths, assuming rhs is NOT absolute. combineAlways :: FilePath -> FilePath -> FilePath combineAlways a b | null a = b | null b = a | isPathSeparator (last a) = a ++ b | isDrive a = joinDrive a b | otherwise = a ++ [pathSeparator] ++ b -- | A nice alias for 'combine'. () :: FilePath -> FilePath -> FilePath () = combine -- | Split a path by the directory separator. -- -- > concat (splitPath x) == x -- > splitPath "test//item/" == ["test//","item/"] -- > splitPath "test/item/file" == ["test/","item/","file"] -- > splitPath "" == [] -- > Windows: splitPath "c:\\test\\path" == ["c:\\","test\\","path"] -- > Posix: splitPath "/file/test" == ["/","file/","test"] splitPath :: FilePath -> [FilePath] splitPath x = [drive | drive /= ""] ++ f path where (drive,path) = splitDrive x f [] = [] f y@(_:_) = (a ++ c) : f d where (a,b) = break isPathSeparator y (c,d) = break (not . isPathSeparator) b -- | Just as 'splitPath', but don't add the trailing slashes to each element. -- -- > splitDirectories "test/file" == ["test","file"] -- > splitDirectories "/test/file" == ["/","test","file"] -- > Valid x => joinPath (splitDirectories x) `equalFilePath` x -- > splitDirectories "" == [] splitDirectories :: FilePath -> [FilePath] splitDirectories path = if hasDrive path then head pathComponents : f (tail pathComponents) else f pathComponents where pathComponents = splitPath path f xs = map g xs g x = if null res then x else res where res = takeWhile (not . isPathSeparator) x -- | Join path elements back together. -- -- > Valid x => joinPath (splitPath x) == x -- > joinPath [] == "" -- > Posix: joinPath ["test","file","path"] == "test/file/path" -- Note that this definition on c:\\c:\\, join then split will give c:\\. joinPath :: [FilePath] -> FilePath joinPath x = foldr combine "" x --------------------------------------------------------------------- -- File name manipulators -- | Equality of two 'FilePath's. -- If you call @System.Directory.canonicalizePath@ -- first this has a much better chance of working. -- Note that this doesn't follow symlinks or DOSNAM~1s. -- -- > x == y ==> equalFilePath x y -- > normalise x == normalise y ==> equalFilePath x y -- > Posix: equalFilePath "foo" "foo/" -- > Posix: not (equalFilePath "foo" "/foo") -- > Posix: not (equalFilePath "foo" "FOO") -- > Windows: equalFilePath "foo" "FOO" equalFilePath :: FilePath -> FilePath -> Bool equalFilePath a b = f a == f b where f x | isWindows = dropTrailSlash $ map toLower $ normalise x | otherwise = dropTrailSlash $ normalise x dropTrailSlash x | length x >= 2 && isPathSeparator (last x) = init x | otherwise = x -- | Contract a filename, based on a relative path. -- -- There is no corresponding @makeAbsolute@ function, instead use -- @System.Directory.canonicalizePath@ which has the same effect. -- -- > Valid y => equalFilePath x y || (isRelative x && makeRelative y x == x) || equalFilePath (y makeRelative y x) x -- > makeRelative x x == "." -- > null y || equalFilePath (makeRelative x (x y)) y || null (takeFileName x) -- > Windows: makeRelative "C:\\Home" "c:\\home\\bob" == "bob" -- > Windows: makeRelative "C:\\Home" "c:/home/bob" == "bob" -- > Windows: makeRelative "C:\\Home" "D:\\Home\\Bob" == "D:\\Home\\Bob" -- > Windows: makeRelative "C:\\Home" "C:Home\\Bob" == "C:Home\\Bob" -- > Windows: makeRelative "/Home" "/home/bob" == "bob" -- > Posix: makeRelative "/Home" "/home/bob" == "/home/bob" -- > Posix: makeRelative "/home/" "/home/bob/foo/bar" == "bob/foo/bar" -- > Posix: makeRelative "/fred" "bob" == "bob" -- > Posix: makeRelative "/file/test" "/file/test/fred" == "fred" -- > Posix: makeRelative "/file/test" "/file/test/fred/" == "fred/" -- > Posix: makeRelative "some/path" "some/path/a/b/c" == "a/b/c" makeRelative :: FilePath -> FilePath -> FilePath makeRelative root path | equalFilePath root path = "." | takeAbs root /= takeAbs path = path | otherwise = f (dropAbs root) (dropAbs path) where f [] y = dropWhile isPathSeparator y f x@(_:_) y = let (x1,x2) = g x (y1,y2) = g y in if equalFilePath x1 y1 then f x2 y2 else path g x = (dropWhile isPathSeparator a, dropWhile isPathSeparator b) where (a,b) = break isPathSeparator $ dropWhile isPathSeparator x -- on windows, need to drop '/' which is kind of absolute, but not a drive dropAbs [] = dropDrive [] dropAbs (x:xs) | isPathSeparator x = xs | otherwise = dropDrive (x:xs) takeAbs [] = map (\y -> if isPathSeparator y then pathSeparator else toLower y) $ takeDrive [] takeAbs xs@(x:_) | isPathSeparator x = [pathSeparator] | otherwise = map (\y -> if isPathSeparator y then pathSeparator else toLower y) $ takeDrive xs -- | Normalise a file -- -- * \/\/ outside of the drive can be made blank -- -- * \/ -> 'pathSeparator' -- -- * .\/ -> \"\" -- -- > Posix: normalise "/file/\\test////" == "/file/\\test/" -- > Posix: normalise "/file/./test" == "/file/test" -- > Posix: normalise "/test/file/../bob/fred/" == "/test/file/../bob/fred/" -- > Posix: normalise "../bob/fred/" == "../bob/fred/" -- > Posix: normalise "./bob/fred/" == "bob/fred/" -- > Windows: normalise "c:\\file/bob\\" == "C:\\file\\bob\\" -- > Windows: normalise "c:\\" == "C:\\" -- > Windows: normalise "\\\\server\\test" == "\\\\server\\test" -- > Windows: normalise "c:/file" == "C:\\file" -- > normalise "." == "." -- > Posix: normalise "./" == "./" -- > Posix: normalise "./." == "./" -- > Posix: normalise "bob/fred/." == "bob/fred/" normalise :: FilePath -> FilePath normalise path = joinDrive (normaliseDrive drv) (f pth) ++ [pathSeparator | isDirPath pth] where (drv,pth) = splitDrive path isDirPath xs = lastSep xs || not (null xs) && last xs == '.' && lastSep (init xs) lastSep xs = not (null xs) && isPathSeparator (last xs) f = joinPath . dropDots . splitDirectories . propSep propSep [] = [] propSep xs@[x] | isPathSeparator x = [pathSeparator] | otherwise = xs propSep (x:y:xs) | isPathSeparator x && isPathSeparator y = propSep (x:xs) | isPathSeparator x = pathSeparator : propSep (y:xs) | otherwise = x : propSep (y:xs) dropDots xs | all (== ".") xs = ["."] | otherwise = dropDots' [] xs dropDots' acc [] = reverse acc dropDots' acc (x:xs) | x == "." = dropDots' acc xs | otherwise = dropDots' (x:acc) xs normaliseDrive :: FilePath -> FilePath normaliseDrive drive | isPosix = drive | otherwise = if isJust $ readDriveLetter x2 then map toUpper x2 else drive where x2 = map repSlash drive repSlash x = if isPathSeparator x then pathSeparator else x -- information for validity functions on Windows -- see http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp badCharacters :: [Char] badCharacters = ":*?><|\"" badElements :: [FilePath] badElements = ["CON", "PRN", "AUX", "NUL", "COM1", "COM2", "COM3", "COM4", "COM5", "COM6", "COM7", "COM8", "COM9", "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6", "LPT7", "LPT8", "LPT9", "CLOCK$"] -- | Is a FilePath valid, i.e. could you create a file like it? -- -- > isValid "" == False -- > Posix: isValid "/random_ path:*" == True -- > Posix: isValid x == not (null x) -- > Windows: isValid "c:\\test" == True -- > Windows: isValid "c:\\test:of_test" == False -- > Windows: isValid "test*" == False -- > Windows: isValid "c:\\test\\nul" == False -- > Windows: isValid "c:\\test\\prn.txt" == False -- > Windows: isValid "c:\\nul\\file" == False -- > Windows: isValid "\\\\" == False isValid :: FilePath -> Bool isValid [] = False isValid path@(_:_) | isPosix = True | otherwise = not (any (`elem` badCharacters) x2) && not (any f $ splitDirectories x2) && not (length path >= 2 && all isPathSeparator path) where x2 = dropDrive path f x = map toUpper (dropExtensions x) `elem` badElements -- | Take a FilePath and make it valid; does not change already valid FilePaths. -- -- > isValid (makeValid x) -- > isValid x ==> makeValid x == x -- > makeValid "" == "_" -- > Windows: makeValid "c:\\test:of_test" == "c:\\test_of_test" -- > Windows: makeValid "test*" == "test_" -- > Windows: makeValid "c:\\test\\nul" == "c:\\test\\nul_" -- > Windows: makeValid "c:\\test\\prn.txt" == "c:\\test\\prn_.txt" -- > Windows: makeValid "c:\\test/prn.txt" == "c:\\test/prn_.txt" -- > Windows: makeValid "c:\\nul\\file" == "c:\\nul_\\file" makeValid :: FilePath -> FilePath makeValid [] = "_" makeValid path@(_:_) | isPosix = path | length path >= 2 && all isPathSeparator path = take 2 path ++ "drive" | otherwise = joinDrive drv $ validElements $ validChars pth where (drv,pth) = splitDrive path validChars x = map f x f x | x `elem` badCharacters = '_' | otherwise = x validElements x = joinPath $ map g $ splitPath x g x = h (reverse b) ++ reverse a where (a,b) = span isPathSeparator $ reverse x h x = if map toUpper a `elem` badElements then a ++ "_" <.> b else x where (a,b) = splitExtensions x -- | Is a path relative, or is it fixed to the root? -- -- > Windows: isRelative "path\\test" == True -- > Windows: isRelative "c:\\test" == False -- > Windows: isRelative "c:test" == True -- > Windows: isRelative "c:" == True -- > Windows: isRelative "\\\\foo" == False -- > Windows: isRelative "/foo" == True -- > Posix: isRelative "test/path" == True -- > Posix: isRelative "/test" == False isRelative :: FilePath -> Bool isRelative = isRelativeDrive . takeDrive -- > isRelativeDrive "" == True -- > Windows: isRelativeDrive "c:\\" == False -- > Windows: isRelativeDrive "c:/" == False -- > Windows: isRelativeDrive "c:" == True -- > Windows: isRelativeDrive "\\\\foo" == False -- > Posix: isRelativeDrive "/" == False isRelativeDrive :: String -> Bool isRelativeDrive x = null x || maybe False (not . isPathSeparator . last . fst) (readDriveLetter x) -- | @not . 'isRelative'@ -- -- > isAbsolute x == not (isRelative x) isAbsolute :: FilePath -> Bool isAbsolute = not . isRelative curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Findall.curry000066400000000000000000000074241305333611600236760ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library with some operations for encapsulating search. --- Note that some of these operations are not fully declarative, --- i.e., the results depend on the order of evaluation and program rules. --- There are newer and better approaches the encpasulate search, --- in particular, set functions (see module `SetFunctions`), --- which should be used. --- --- This library is included only for compatibility with PAKCS. --- --- @author Michael Hanus --- @version July 2015 --- @category general ------------------------------------------------------------------------------ module Findall ( getAllValues, getSomeValue , allValues, someValue , allSolutions, someSolution ) where import qualified SearchTree as ST --- Gets all values of an expression (currently, via an incomplete --- depth-first strategy). Conceptually, all values are computed --- on a copy of the expression, i.e., the evaluation of the expression --- does not share any results. Moreover, the evaluation suspends --- as long as the expression contains unbound variables. --- Similar to Prolog's findall. getAllValues :: a -> IO [a] getAllValues e = return (allValues e) --- Gets a value of an expression (currently, via an incomplete --- depth-first strategy). The expression must have a value, otherwise --- the computation fails. Conceptually, the value is computed on a copy --- of the expression, i.e., the evaluation of the expression does not share --- any results. Moreover, the evaluation suspends as long as the expression --- contains unbound variables. getSomeValue :: a -> IO a getSomeValue e = return (someValue e) --- Returns all values of an expression (currently, via an incomplete --- depth-first strategy). Conceptually, all values are computed on a copy --- of the expression, i.e., the evaluation of the expression does not share --- any results. --- --- Note that this operation is not purely declarative since the ordering --- of the computed values depends on the ordering of the program rules. allValues :: a -> [a] allValues e = ST.allValuesDFS (ST.someSearchTree e) --- Returns some value for an expression (currently, via an incomplete --- depth-first strategy). If the expression has no value, the --- computation fails. --- Conceptually, the value is computed on a copy of the expression, --- i.e., the evaluation of the expression does not share any results. --- --- Note that this operation is not purely declarative since --- the computed value depends on the ordering of the program rules. --- Thus, this operation should be used only if the expression --- has a single value. someValue :: a -> a someValue = ST.someValueWith ST.dfsStrategy --- Returns all values satisfying a predicate, i.e., all arguments such that --- the predicate applied to the argument can be evaluated to `True` --- (currently, via an incomplete depth-first strategy). --- --- Note that this operation is not purely declarative since the ordering --- of the computed values depends on the ordering of the program rules. allSolutions :: (a->Bool) -> [a] allSolutions p = allValues (let x free in p x &> x) --- Returns some values satisfying a predicate, i.e., some argument such that --- the predicate applied to the argument can be evaluated to `True` --- (currently, via an incomplete depth-first strategy). --- If there is no value satisfying the predicate, the computation fails. --- --- Note that this operation is not purely declarative since the ordering --- of the computed values depends on the ordering of the program rules. --- Thus, this operation should be used only if the --- predicate has a single solution. someSolution :: (a->Bool) -> a someSolution p = someValue (let x free in p x &> x) ------------------------------------------------------------------------------ curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Findall.curry.pakcs000066400000000000000000000201011305333611600247610ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library with some operations for encapsulating search. --- Note that some of these operations are not fully declarative, --- i.e., the results depend on the order of evaluation and program rules. --- There are newer and better approaches the encpasulate search, --- in particular, set functions (see module `SetFunctions`), --- which should be used. --- --- In previous versions of PAKCS, some of these operations were part of --- the standard prelude. We keep them in this separate module --- in order to support a more portable standard prelude. --- --- @author Michael Hanus --- @version July 2015 --- @category general ------------------------------------------------------------------------------ {-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-} module Findall ( getAllValues, getSomeValue , allValues, someValue , allSolutions, someSolution , try, inject, solveAll, once, best , findall, findfirst, browse, browseList, unpack , rewriteAll, rewriteSome ) where --- Gets all values of an expression (currently, via an incomplete --- depth-first strategy). Conceptually, all values are computed --- on a copy of the expression, i.e., the evaluation of the expression --- does not share any results. Moreover, the evaluation suspends --- as long as the expression contains unbound variables. --- Similar to Prolog's findall. getAllValues :: a -> IO [a] getAllValues e = return (allValues e) --- Gets a value of an expression (currently, via an incomplete --- depth-first strategy). The expression must have a value, otherwise --- the computation fails. Conceptually, the value is computed on a copy --- of the expression, i.e., the evaluation of the expression does not share --- any results. Moreover, the evaluation suspends as long as the expression --- contains unbound variables. getSomeValue :: a -> IO a getSomeValue e = return (someValue e) --- Returns all values of an expression (currently, via an incomplete --- depth-first strategy). Conceptually, all values are computed on a copy --- of the expression, i.e., the evaluation of the expression does not share --- any results. Moreover, the evaluation suspends as long as the expression --- contains unbound variables. --- --- Note that this operation is not purely declarative since the ordering --- of the computed values depends on the ordering of the program rules. allValues :: a -> [a] allValues e = findall (\x -> x=:=e) --- Returns some value for an expression (currently, via an incomplete --- depth-first strategy). If the expression has no value, the --- computation fails. Conceptually, the value is computed on a copy --- of the expression, i.e., the evaluation of the expression does not share --- any results. Moreover, the evaluation suspends as long as the expression --- contains unbound variables. --- --- Note that this operation is not purely declarative since --- the computed value depends on the ordering of the program rules. --- Thus, this operation should be used only if the expression --- has a single value. someValue :: a -> a someValue e = findfirst (=:=e) --- Returns all values satisfying a predicate, i.e., all arguments such that --- the predicate applied to the argument can be evaluated to `True` --- (currently, via an incomplete depth-first strategy). --- The evaluation suspends as long as the predicate expression --- contains unbound variables. --- --- Note that this operation is not purely declarative since the ordering --- of the computed values depends on the ordering of the program rules. allSolutions :: (a->Bool) -> [a] allSolutions p = findall (\x -> p x =:= True) --- Returns some values satisfying a predicate, i.e., some argument such that --- the predicate applied to the argument can be evaluated to `True` --- (currently, via an incomplete depth-first strategy). --- If there is no value satisfying the predicate, the computation fails. --- --- Note that this operation is not purely declarative since the ordering --- of the computed values depends on the ordering of the program rules. --- Thus, this operation should be used only if the --- predicate has a single solution. someSolution :: (a->Bool) -> a someSolution p = findfirst (\x -> p x =:= True) ------------------------------------------------------------------------------ --- Basic search control operator. try :: (a -> Bool) -> [a -> Bool] try external --- Inject operator which adds the application of the unary --- procedure p to the search variable to the search goal --- taken from Oz. p x comes before g x to enable a test+generate --- form in a sequential implementation. inject :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) inject g p = \x -> p x & g x --- Computes all solutions via a a depth-first strategy. -- -- Works as the following algorithm: -- -- solveAll g = evalResult (try g) -- where -- evalResult [] = [] -- evalResult [s] = [s] -- evalResult (a:b:c) = concatMap solveAll (a:b:c) -- -- The following solveAll algorithm is faster. -- For comparison we have solveAll2, which implements the above algorithm. solveAll :: (a -> Bool) -> [a -> Bool] solveAll g = evalall (try g) where evalall [] = [] evalall [a] = [a] evalall (a:b:c) = evalall3 (try a) (b:c) evalall2 [] = [] evalall2 (a:b) = evalall3 (try a) b evalall3 [] b = evalall2 b evalall3 [l] b = l : evalall2 b evalall3 (c:d:e) b = evalall3 (try c) (d:e ++b) solveAll2 :: (a -> Bool) -> [a -> Bool] solveAll2 g = evalResult (try g) where evalResult [] = [] evalResult [s] = [s] evalResult (a:b:c) = concatMap solveAll2 (a:b:c) --- Gets the first solution via a depth-first strategy. once :: (a -> Bool) -> (a -> Bool) once g = head (solveAll g) --- Gets the best solution via a depth-first strategy according to --- a specified operator that can always take a decision which --- of two solutions is better. --- In general, the comparison operation should be rigid in its arguments! best :: (a -> Bool) -> (a -> a -> Bool) -> [a -> Bool] best g cmp = bestHelp [] (try g) [] where bestHelp [] [] curbest = curbest bestHelp [] (y:ys) curbest = evalY (try (constrain y curbest)) ys curbest bestHelp (x:xs) ys curbest = evalX (try x) xs ys curbest evalY [] ys curbest = bestHelp [] ys curbest evalY [newbest] ys _ = bestHelp [] ys [newbest] evalY (c:d:xs) ys curbest = bestHelp (c:d:xs) ys curbest evalX [] xs ys curbest = bestHelp xs ys curbest evalX [newbest] xs ys _ = bestHelp [] (xs++ys) [newbest] evalX (c:d:e) xs ys curbest = bestHelp ((c:d:e)++xs) ys curbest constrain y [] = y constrain y [curbest] = inject y (\v -> let w free in curbest w & cmp v w =:= True) --- Gets all solutions via a depth-first strategy and unpack --- the values from the lambda-abstractions. --- Similar to Prolog's findall. findall :: (a -> Bool) -> [a] findall g = map unpack (solveAll g) --- Gets the first solution via a depth-first strategy --- and unpack the values from the search goals. findfirst :: (a -> Bool) -> a findfirst g = head (findall g) --- Shows the solution of a solved constraint. browse :: (_ -> Bool) -> IO () browse g = putStr (show (unpack g)) --- Unpacks solutions from a list of lambda abstractions and write --- them to the screen. browseList :: [_ -> Bool] -> IO () browseList [] = done browseList (g:gs) = browse g >> putChar '\n' >> browseList gs --- Unpacks a solution's value from a (solved) search goal. unpack :: (a -> Bool) -> a unpack g | g x = x where x free --- Gets all values computable by term rewriting. --- In contrast to `findall`, this operation does not wait --- until all "outside" variables are bound to values, --- but it returns all values computable by term rewriting --- and ignores all computations that requires bindings for outside variables. rewriteAll :: a -> [a] rewriteAll external --- Similarly to 'rewriteAll' but returns only some value computable --- by term rewriting. Returns `Nothing` if there is no such value. rewriteSome :: a -> Maybe a rewriteSome external curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Findall.prim_c2p000066400000000000000000000014041305333611600242350ustar00rootroot00000000000000 prim_standard prim_findall[raw] prim_standard prim_findfirst[raw] prim_standard prim_try[raw] prim_standard prim_rewriteAll[raw] prim_standard prim_rewriteSome[raw] curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/FiniteMap.curry000066400000000000000000000677421305333611600242120ustar00rootroot00000000000000----------------------------------------------------------------------------- --- A finite map is an efficient purely functional data structure --- to store a mapping from keys to values. --- In order to store the mapping efficiently, an irreflexive(!) order predicate --- has to be given, i.e., the order predicate `le` should not satisfy --- `(le x x)` for some key `x`. --- --- Example: To store a mapping from `Int -> String`, the finite map needs --- a Boolean predicate like `(<)`. --- This version was ported from a corresponding Haskell library --- --- @author Frank Huch, Bernd Brassel --- @version March 2013 --- @category algorithm ----------------------------------------------------------------------------- module FiniteMap ( FM, -- abstract type emptyFM, unitFM, listToFM, addToFM, addToFM_C, addListToFM, addListToFM_C, delFromFM, delListFromFM, splitFM, plusFM, plusFM_C, minusFM, intersectFM, intersectFM_C, foldFM, mapFM, filterFM, sizeFM, eqFM, isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM, keyOrder, fmToList, keysFM, eltsFM, fmSortBy, minFM,maxFM,updFM, fmToListPreOrder, showFM, readFM ) where import Maybe import ReadShowTerm (readQTerm, showQTerm) --- order predicates are boolean type LeKey key = key -> key -> Bool ----------------------------------------------- -- BUILDING finite maps ----------------------------------------------- --- The empty finite map. --- @param le an irreflexive order predicate on the keys. --- @result an empty finite map emptyFM :: (LeKey key) -> FM key _ emptyFM le = FM le EmptyFM --- Construct a finite map with only a single element. --- @param le an irreflexive order predicate on the keys. --- @param key key of --- @param elt the single element to form --- @result a finite map with only a single element unitFM :: (LeKey key) -> key -> elt -> FM key elt unitFM le key elt = FM le (unitFM' key elt) unitFM' :: key -> elt -> FiniteMap key elt unitFM' key elt = BranchFM key elt 1 EmptyFM EmptyFM --- Builts a finite map from given list of tuples (key,element). --- For multiple occurences of key, the last corresponding --- element of the list is taken. --- @param le an irreflexive order predicate on the keys. listToFM :: (LeKey key) -> [(key,elt)] -> FM key elt listToFM le = addListToFM (emptyFM le) ----------------------------------------------- -- ADDING AND DELETING ----------------------------------------------- --- Throws away any previous binding and stores the new one given. addToFM :: FM key elt -> key -> elt -> FM key elt addToFM (FM le fm) key elt = FM le (addToFM' le fm key elt) addToFM' :: (LeKey key) -> FiniteMap key elt -> key -> elt -> FiniteMap key elt addToFM' le fm key elt = addToFM_C' le (\ _ new -> new) fm key elt addToFM_C' :: (LeKey key) -> (elt -> elt -> elt) -> FiniteMap key elt -> key -> elt -> FiniteMap key elt addToFM_C' _ _ EmptyFM key elt = unitFM' key elt addToFM_C' le combiner (BranchFM key elt size fm_l fm_r) new_key new_elt = if le new_key key then mkBalBranch key elt (addToFM_C' le combiner fm_l new_key new_elt) fm_r else if new_key==key then BranchFM new_key (combiner elt new_elt) size fm_l fm_r else mkBalBranch key elt fm_l (addToFM_C' le combiner fm_r new_key new_elt) --- Throws away any previous bindings and stores the new ones given. --- The items are added starting with the first one in the list addListToFM :: FM key elt -> [(key,elt)] -> FM key elt addListToFM (FM le fm) key_elt_pairs = FM le (addListToFM' le fm key_elt_pairs) addListToFM' :: (LeKey key) -> FiniteMap key elt -> [(key, elt)] -> FiniteMap key elt addListToFM' le fm key_elt_pairs = addListToFM_C' le (\ _ new -> new) fm key_elt_pairs addListToFM_C' :: (LeKey key) -> (elt -> elt -> elt) -> FiniteMap key elt -> [(key, elt)] -> FiniteMap key elt addListToFM_C' le combiner fm key_elt_pairs = foldl add fm key_elt_pairs -- foldl adds from the left where add fmap (key,elt) = addToFM_C' le combiner fmap key elt --- Instead of throwing away the old binding, --- addToFM_C combines the new element with the old one. --- @param combiner a function combining to elements --- @param fm a finite map --- @param key the key of the elements to be combined --- @param elt the new element --- @result a modified finite map addToFM_C :: (elt -> elt -> elt) -> FM key elt -> key -> elt -> FM key elt addToFM_C combiner (FM le fm) key elt = FM le (addToFM_C' le combiner fm key elt) --- Combine with a list of tuples (key,element), cf. addToFM_C addListToFM_C :: (elt -> elt -> elt) -> FM key elt -> [(key,elt)] -> FM key elt addListToFM_C combiner (FM le fm) key_elt_pairs = FM le (addListToFM_C' le combiner fm key_elt_pairs) --- Deletes key from finite map. --- Deletion doesn't complain if you try to delete something --- which isn't there delFromFM :: FM key elt -> key -> FM key elt delFromFM (FM le fm) del_key = FM le (delFromFM' le fm del_key) delFromFM' :: (LeKey key) -> FiniteMap key elt -> key -> FiniteMap key elt delFromFM' _ EmptyFM _ = EmptyFM delFromFM' le (BranchFM key elt _ fm_l fm_r) del_key = if le del_key key then mkBalBranch key elt (delFromFM' le fm_l del_key) fm_r else if del_key==key then glueBal le fm_l fm_r else mkBalBranch key elt fm_l (delFromFM' le fm_r del_key) --- Deletes a list of keys from finite map. --- Deletion doesn't complain if you try to delete something --- which isn't there delListFromFM :: FM key elt -> [key] -> FM key elt delListFromFM (FM le fm) keys = FM le (foldl (delFromFM' le) fm keys) --- Applies a function to element bound to given key. updFM :: FM a b -> a -> (b -> b) -> FM a b updFM (FM lt fm) i f = FM lt (upd fm) where upd EmptyFM = EmptyFM upd (BranchFM k x h l r) | i == k = BranchFM k (f x) h l r | lt i k = BranchFM k x h (upd l) r | otherwise = BranchFM k x h l (upd r) --- Combines delFrom and lookup. splitFM :: FM a b -> a -> Maybe (FM a b,(a,b)) splitFM g v = maybe Nothing (\x->Just (delFromFM g v,(v,x))) (lookupFM g v) ------------------------------------------------- -- COMBINING finite maps ------------------------------------------------- --- Efficiently add key/element mappings of two maps into a single one. --- Bindings in right argument shadow those in the left plusFM :: FM key elt -> FM key elt -> FM key elt plusFM (FM le1 fm1) (FM _ fm2) = FM le1 (plusFM' le1 fm1 fm2) plusFM' :: (LeKey key) -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt plusFM' _ EmptyFM fm2 = fm2 plusFM' _ (BranchFM split_key1 elt1 s1 left1 right1) EmptyFM = (BranchFM split_key1 elt1 s1 left1 right1) plusFM' le (BranchFM split_key1 elt1 s1 left1 right1) (BranchFM split_key elt2 _ left right) = mkVBalBranch le split_key elt2 (plusFM' le lts left) (plusFM' le gts right) where fm1 = BranchFM split_key1 elt1 s1 left1 right1 lts = splitLT le fm1 split_key gts = splitGT le fm1 split_key --- Efficiently combine key/element mappings of two maps into a single one, --- cf. addToFM_C plusFM_C :: (elt -> elt -> elt) -> FM key elt -> FM key elt -> FM key elt plusFM_C combiner (FM le1 fm1) (FM _ fm2) = FM le1 (plusFM_C' le1 combiner fm1 fm2) plusFM_C' :: LeKey key -> (elt -> elt -> elt) -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt plusFM_C' _ _ EmptyFM fm2 = fm2 plusFM_C' _ _ (BranchFM split_key1 elt1 s1 left1 right1) EmptyFM = BranchFM split_key1 elt1 s1 left1 right1 plusFM_C' le combiner (BranchFM split_key1 elt1 s1 left1 right1) (BranchFM split_key elt2 _ left right) = mkVBalBranch le split_key new_elt (plusFM_C' le combiner lts left) (plusFM_C' le combiner gts right) where fm1 = BranchFM split_key1 elt1 s1 left1 right1 lts = splitLT le fm1 split_key gts = splitGT le fm1 split_key new_elt = case lookupFM' le fm1 split_key of Nothing -> elt2 Just elt1' -> combiner elt1' elt2 --- (minusFM a1 a2) deletes from a1 any bindings which are bound in a2 minusFM :: FM key elt -> FM key elt -> FM key elt minusFM (FM le1 fm1) (FM _ fm2) = FM le1 (minusFM' le1 fm1 fm2) minusFM' :: (LeKey key) -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt minusFM' _ EmptyFM _ = EmptyFM minusFM' _ (BranchFM split_key1 elt1 s1 left1 right1) EmptyFM = BranchFM split_key1 elt1 s1 left1 right1 minusFM' le (BranchFM split_key1 elt1 s1 left1 right1) (BranchFM split_key _ _ left right) = glueVBal le (minusFM' le lts left) (minusFM' le gts right) -- The two can be way different, so we need glueVBal where fm1 = BranchFM split_key1 elt1 s1 left1 right1 lts = splitLT le fm1 split_key -- NB gt and lt, so the equal ones gts = splitGT le fm1 split_key -- are not in either. --- Filters only those keys that are bound in both of the given maps. --- The elements will be taken from the second map. intersectFM :: FM key elt -> FM key elt -> FM key elt intersectFM (FM le1 fm1) (FM _ fm2) = FM le1 (intersectFM' le1 fm1 fm2) intersectFM' :: LeKey key -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt intersectFM' le fm1 fm2 = intersectFM_C' le (\ _ right -> right) fm1 fm2 --- Filters only those keys that are bound in both of the given maps --- and combines the elements as in addToFM_C. intersectFM_C :: (elt -> elt2 -> elt3) -> FM key elt -> FM key elt2 -> FM key elt3 intersectFM_C combiner (FM le1 fm1) (FM _ fm2) = FM le1 (intersectFM_C' le1 combiner fm1 fm2) intersectFM_C' :: LeKey key -> (elt -> elt2 -> elt3) -> FiniteMap key elt -> FiniteMap key elt2 -> FiniteMap key elt3 intersectFM_C' _ _ _ EmptyFM = EmptyFM intersectFM_C' _ _ EmptyFM (BranchFM _ _ _ _ _) = EmptyFM intersectFM_C' le combiner (BranchFM split_key1 elt1 s1 left1 right1) (BranchFM split_key elt2 _ left right) | isJust maybe_elt1 -- split_elt *is* in intersection = mkVBalBranch le split_key (combiner elt1' elt2) (intersectFM_C' le combiner lts left) (intersectFM_C' le combiner gts right) | otherwise -- split_elt is *not* in intersection = glueVBal le (intersectFM_C' le combiner lts left) (intersectFM_C' le combiner gts right) where fm1 = BranchFM split_key1 elt1 s1 left1 right1 lts = splitLT le fm1 split_key -- NB gt and lt, so the equal ones gts = splitGT le fm1 split_key -- are not in either. maybe_elt1 = lookupFM' le fm1 split_key Just elt1' = maybe_elt1 ------------------------------------------------------------- -- MAPPING, FOLDING, FILTERING on finite maps ------------------------------------------------------------- --- Folds finite map by given function. foldFM :: (key -> elt -> a -> a) -> a -> FM key elt -> a foldFM k z (FM le fm) = foldFM' le k z fm foldFM' :: LeKey key -> (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a foldFM' _ _ z EmptyFM = z foldFM' le k z (BranchFM key elt _ fm_l fm_r) = foldFM' le k (k key elt (foldFM' le k z fm_r)) fm_l --- Applies a given function on every element in the map. mapFM :: (key -> elt1 -> elt2) -> FM key elt1 -> FM key elt2 mapFM f (FM le fm) = FM le (mapFM' le f fm) mapFM' :: LeKey key -> (key -> elt1 -> elt2) -> FiniteMap key elt1 -> FiniteMap key elt2 mapFM' _ _ EmptyFM = EmptyFM mapFM' le f (BranchFM key elt size fm_l fm_r) = BranchFM key (f key elt) size (mapFM' le f fm_l) (mapFM' le f fm_r) --- Yields a new finite map with only those key/element pairs matching the --- given predicate. filterFM :: (key -> elt -> Bool) -> FM key elt -> FM key elt filterFM p (FM le fm) = FM le (filterFM' le p fm) filterFM' :: LeKey key -> (key -> elt -> Bool) -> FiniteMap key elt -> FiniteMap key elt filterFM' _ _ EmptyFM = EmptyFM filterFM' le p (BranchFM key elt _ fm_l fm_r) | p key elt -- Keep the item = mkVBalBranch le key elt (filterFM' le p fm_l) (filterFM' le p fm_r) | otherwise -- Drop the item = glueVBal le (filterFM' le p fm_l) (filterFM' le p fm_r) ----------------------------------------------------- -- INTERROGATING finite maps ----------------------------------------------------- --- How many elements does given map contain? sizeFM :: FM _ _ -> Int sizeFM (FM _ EmptyFM) = 0 sizeFM (FM _ (BranchFM _ _ size _ _)) = size sizeFM' :: FiniteMap _ _ -> Int sizeFM' EmptyFM = 0 sizeFM' (BranchFM _ _ size _ _) = size --- Do two given maps contain the same key/element pairs? eqFM :: FM key elt -> FM key elt -> Bool fm_1 `eqFM` fm_2 = (sizeFM fm_1 == sizeFM fm_2) && -- quick test (fmToList fm_1 == fmToList fm_2) --- Is the given finite map empty? isEmptyFM :: FM _ _ -> Bool isEmptyFM fm = sizeFM fm == 0 --- Does given map contain given key? elemFM :: key -> FM key _ -> Bool key `elemFM` fm = isJust (lookupFM fm key) --- Retrieves element bound to given key lookupFM :: FM key elt -> key -> Maybe elt lookupFM (FM le fm) key = lookupFM' le fm key lookupFM' :: LeKey key -> FiniteMap key elt -> key -> Maybe elt lookupFM' _ EmptyFM _ = Nothing lookupFM' le (BranchFM key elt _ fm_l fm_r) key_to_find = if le key_to_find key then lookupFM' le fm_l key_to_find else if key_to_find==key then Just elt else lookupFM' le fm_r key_to_find --- Retrieves element bound to given key. --- If the element is not contained in map, return --- default value. lookupWithDefaultFM :: FM key elt -> elt -> key -> elt lookupWithDefaultFM fm deflt key = case lookupFM fm key of Nothing -> deflt Just elt -> elt --- Retrieves the ordering on which the given finite map is built. keyOrder :: FM key _ -> (key->key->Bool) keyOrder (FM lt _) = lt --- Retrieves the smallest key/element pair in the finite map --- according to the basic key ordering. minFM :: FM a b -> Maybe (a,b) minFM = min . tree where min EmptyFM = Nothing min (BranchFM k x _ l _) | isBranchFM l = min l | otherwise = Just (k,x) --- Retrieves the greatest key/element pair in the finite map --- according to the basic key ordering. maxFM :: FM a b -> Maybe (a,b) maxFM = max . tree where max EmptyFM = Nothing max (BranchFM k x _ _ r) | isBranchFM r = max r | otherwise = Just (k,x) ---------------------------------------------------- -- LISTIFYING: transform finite maps to lists ---------------------------------------------------- --- Builds a list of key/element pairs. The list is ordered --- by the initially given irreflexive order predicate on keys. fmToList :: FM key elt -> [(key,elt)] fmToList fm = foldFM (\ key elt rest -> (key,elt) : rest) [] fm --- Retrieves a list of keys contained in finite map. --- The list is ordered --- by the initially given irreflexive order predicate on keys. keysFM :: FM key _ -> [key] keysFM fm = foldFM (\ key _ rest -> key : rest) [] fm --- Retrieves a list of elements contained in finite map. --- The list is ordered --- by the initially given irreflexive order predicate on keys. eltsFM :: FM _ elt -> [elt] eltsFM fm = foldFM (\ _ elt rest -> elt : rest) [] fm --- Retrieves list of key/element pairs in preorder of the internal tree. --- Useful for lists that will be retransformed into a tree or to match --- any elements regardless of basic order. fmToListPreOrder :: FM key elt -> [(key,elt)] fmToListPreOrder (FM _ fm) = pre fm [] where pre EmptyFM xs = xs pre (BranchFM k x _ l r) xs = (k,x):pre l (pre r xs) --- Sorts a given list by inserting and retrieving from finite map. --- Duplicates are deleted. fmSortBy :: LeKey key -> [key] -> [key] fmSortBy p l = keysFM (listToFM p (zip l (repeat ()))) ----------------------------------------------------- -- reading/showing finite maps ----------------------------------------------------- --- Transforms a finite map into a string. For efficiency reasons, --- the tree structure is shown which is valid for reading only if one --- uses the same ordering predicate. showFM :: FM _ _ -> String showFM (FM _ fm) = showQTerm fm --- Transforms a string representation of a finite map into a finite map. --- One has two provide the same ordering predicate as used in the --- original finite map. readFM :: LeKey key -> String -> FM key _ readFM p s = FM p (readQTerm s) ----------------------------------------------------- -- internal Implementation ----------------------------------------------------- data FM key elt = FM (LeKey key) (FiniteMap key elt) tree :: FM key elt -> FiniteMap key elt tree (FM _ fm) = fm data FiniteMap key elt = EmptyFM | BranchFM key elt -- Key and elt stored here Int{-STRICT-} -- Size >= 1 (FiniteMap key elt) -- Children (FiniteMap key elt) isEmptyFM' :: FiniteMap _ _ -> Bool isEmptyFM' fm = sizeFM' fm == 0 isBranchFM :: FiniteMap _ _ -> Bool isBranchFM (BranchFM _ _ _ _ _) = True isBranchFM EmptyFM = False ------------------------------------------------------------------------- -- - -- The implementation of balancing - -- - ------------------------------------------------------------------------- ------------------------------------------------------------------------- -- - -- Basic construction of a FiniteMap - -- - ------------------------------------------------------------------------- sIZE_RATIO :: Int sIZE_RATIO = 5 mkBranch :: Int -> key -> elt -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt mkBranch _{-which-} key elt fm_l fm_r = let result = BranchFM key elt (unbox (1 + left_size + right_size)) fm_l fm_r in result -- if sizeFM result <= 8 then -- result -- else -- pprTrace ("mkBranch:"++(show which)) (ppr result) ( -- result -- ) where {-left_ok = case fm_l of EmptyFM -> True BranchFM _ _ _ _ _ -> cmpWithBiggest_left_key key cmpWithBiggest_left_key key' = le (fst (findMax fm_l)) key' right_ok = case fm_r of EmptyFM -> True BranchFM _ _ _ _ _ -> cmpWithSmallest_right_key key cmpWithSmallest_right_key key' = le key' (fst (findMin fm_r)) balance_ok = True -- sigh-} left_size = sizeFM' fm_l right_size = sizeFM' fm_r unbox :: Int -> Int unbox x = x ------------------------------------------------------------------------- -- - -- Balanced construction of a FiniteMap - -- - ------------------------------------------------------------------------- mkBalBranch :: key -> elt -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt mkBalBranch key elt fm_L fm_R | size_l + size_r < 2 = mkBranch 1{-which-} key elt fm_L fm_R | size_r > sIZE_RATIO * size_l -- Right tree too big = case fm_R of BranchFM _ _ _ fm_rl fm_rr -> if sizeFM' fm_rl < 2 * sizeFM' fm_rr then single_L fm_L fm_R else double_L fm_L fm_R -- Other case impossible EmptyFM -> error "FiniteMap.mkBalBranch" | size_l > sIZE_RATIO * size_r -- Left tree too big = case fm_L of BranchFM _ _ _ fm_ll fm_lr -> if sizeFM' fm_lr < 2 * sizeFM' fm_ll then single_R fm_L fm_R else double_R fm_L fm_R -- Other case impossible EmptyFM -> error "FiniteMap.mkBalBranch" | otherwise -- No imbalance = mkBranch 2{-which-} key elt fm_L fm_R where size_l = sizeFM' fm_L size_r = sizeFM' fm_R single_L fm_l (BranchFM key_r elt_r _ fm_rl fm_rr) = mkBranch 3{-which-} key_r elt_r (mkBranch 4{-which-} key elt fm_l fm_rl) fm_rr single_L _ EmptyFM = error "FiniteMap.single_L" double_L fm_l (BranchFM key_r elt_r _ (BranchFM key_rl elt_rl _ fm_rll fm_rlr) fm_rr) = mkBranch 5{-which-} key_rl elt_rl (mkBranch 6{-which-} key elt fm_l fm_rll) (mkBranch 7{-which-} key_r elt_r fm_rlr fm_rr) double_L _ EmptyFM = error "FiniteMap.double_L" double_L _ (BranchFM _ _ _ EmptyFM _) = error "FiniteMap.double_L" single_R (BranchFM key_l elt_l _ fm_ll fm_lr) fm_r = mkBranch 8{-which-} key_l elt_l fm_ll (mkBranch 9{-which-} key elt fm_lr fm_r) single_R EmptyFM _ = error "FiniteMap.single_R" double_R (BranchFM key_l elt_l _ fm_ll (BranchFM key_lr elt_lr _ fm_lrl fm_lrr)) fm_r = mkBranch 10{-which-} key_lr elt_lr (mkBranch 11{-which-} key_l elt_l fm_ll fm_lrl) (mkBranch 12{-which-} key elt fm_lrr fm_r) double_R EmptyFM _ = error "FiniteMap.double_R" double_R (BranchFM _ _ _ _ EmptyFM) _ = error "FiniteMap.double_R" mkVBalBranch :: (LeKey key) -> key -> elt -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt -- Assert: in any call to (mkVBalBranch_C comb key elt l r), -- (a) all keys in l are < all keys in r -- (b) all keys in l are < key -- (c) all keys in r are > key mkVBalBranch le key elt EmptyFM fm_r = addToFM' le fm_r key elt mkVBalBranch le key elt (BranchFM key_l elt_l s_l fm_ll fm_lr) EmptyFM = addToFM' le (BranchFM key_l elt_l s_l fm_ll fm_lr) key elt mkVBalBranch le key elt (BranchFM key_l elt_l s_l fm_ll fm_lr) (BranchFM key_r elt_r s_r fm_rl fm_rr) | sIZE_RATIO * size_l < size_r = mkBalBranch key_r elt_r (mkVBalBranch le key elt fm_l fm_rl) fm_rr | sIZE_RATIO * size_r < size_l = mkBalBranch key_l elt_l fm_ll (mkVBalBranch le key elt fm_lr fm_r) | otherwise = mkBranch 13{-which-} key elt fm_l fm_r where fm_l = BranchFM key_l elt_l s_l fm_ll fm_lr fm_r = BranchFM key_r elt_r s_r fm_rl fm_rr size_l = sizeFM' fm_l size_r = sizeFM' fm_r ------------------------------------------------------------------------- -- - -- Gluing two trees together - -- - ------------------------------------------------------------------------- glueBal :: (LeKey key) -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt glueBal le fm1 fm2 = if isEmptyFM' fm1 then fm2 else if isEmptyFM' fm2 then fm1 else -- The case analysis here (absent in Adams' program) is really to deal -- with the case where fm2 is a singleton. Then deleting the minimum means -- we pass an empty tree to mkBalBranch, which breaks its invariant. let (mid_key1, mid_elt1) = findMax fm1 (mid_key2, mid_elt2) = findMin fm2 in if sizeFM' fm2 > sizeFM' fm1 then mkBalBranch mid_key2 mid_elt2 fm1 (deleteMin le fm2) else mkBalBranch mid_key1 mid_elt1 (deleteMax le fm1) fm2 glueVBal :: (LeKey key) -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt glueVBal le fm_l fm_r = if isEmptyFM' fm_l then fm_r else if isEmptyFM' fm_r then fm_l else let BranchFM key_l elt_l _ fm_ll fm_lr = fm_l BranchFM key_r elt_r _ fm_rl fm_rr = fm_r --(mid_key_l,mid_elt_l) = findMax fm_l --(mid_key_r,mid_elt_r) = findMin fm_r size_l = sizeFM' fm_l size_r = sizeFM' fm_r in if sIZE_RATIO * size_l < size_r then mkBalBranch key_r elt_r (glueVBal le fm_l fm_rl) fm_rr else if sIZE_RATIO * size_r < size_l then mkBalBranch key_l elt_l fm_ll (glueVBal le fm_lr fm_r) -- We now need the same two cases as in glueBal above. else glueBal le fm_l fm_r ------------------------------------------------------------------------- -- - -- Local utilities - -- - ------------------------------------------------------------------------- splitLT, splitGT :: (LeKey key) -> FiniteMap key elt -> key -> FiniteMap key elt -- splitLT fm split_key = fm restricted to keys < split_key -- splitGT fm split_key = fm restricted to keys > split_key splitLT _ EmptyFM _ = EmptyFM splitLT le (BranchFM key elt _ fm_l fm_r) split_key = if le split_key key then splitLT le fm_l split_key else if split_key == key then fm_l else mkVBalBranch le key elt fm_l (splitLT le fm_r split_key) splitGT _ EmptyFM _ = EmptyFM splitGT le (BranchFM key elt _ fm_l fm_r) split_key = if le split_key key then mkVBalBranch le key elt (splitGT le fm_l split_key) fm_r else if split_key == key then fm_r else splitGT le fm_r split_key findMin :: FiniteMap key elt -> (key,elt) findMin EmptyFM = error "FiniteMap.findMin: empty map" findMin (BranchFM key elt _ EmptyFM _) = (key,elt) findMin (BranchFM _ _ _ (BranchFM key_l elt_l s_l fm_ll fm_lr)_) = findMin (BranchFM key_l elt_l s_l fm_ll fm_lr) deleteMin :: (LeKey key) -> FiniteMap key elt -> FiniteMap key elt deleteMin _ EmptyFM = error "FiniteMap.deleteMin: empty map" deleteMin _ (BranchFM _ _ _ EmptyFM fm_r) = fm_r deleteMin le (BranchFM key elt _ (BranchFM key_l elt_l s_l fm_ll fm_lr) fm_r) = mkBalBranch key elt (deleteMin le (BranchFM key_l elt_l s_l fm_ll fm_lr)) fm_r findMax :: FiniteMap key elt -> (key,elt) findMax EmptyFM = error "FiniteMap.findMax: empty map" findMax (BranchFM key elt _ _ EmptyFM) = (key,elt) findMax (BranchFM _ _ _ _ (BranchFM key_r elt_r s_r fm_rl fm_rr)) = findMax (BranchFM key_r elt_r s_r fm_rl fm_rr) deleteMax :: (LeKey key) -> FiniteMap key elt -> FiniteMap key elt deleteMax _ EmptyFM = error "FiniteMap.deleteMax: empty map" deleteMax _ (BranchFM _ _ _ fm_l EmptyFM) = fm_l deleteMax le (BranchFM key elt _ fm_l (BranchFM key_r elt_r s_r fm_rl fm_rr)) = mkBalBranch key elt fm_l (deleteMax le (BranchFM key_r elt_r s_r fm_rl fm_rr)) ------------------------------------------------------------------------- -- - -- FiniteSets---a thin veneer - -- - ------------------------------------------------------------------------- type FiniteSet key = FM key () emptySet :: (LeKey key) -> FiniteSet key mkSet :: (LeKey key) -> [key] -> FiniteSet key isEmptySet :: FiniteSet _ -> Bool elementOf :: key -> FiniteSet key -> Bool minusSet :: FiniteSet key -> FiniteSet key -> FiniteSet key setToList :: FiniteSet key -> [key] union :: FiniteSet key -> FiniteSet key -> FiniteSet key emptySet = emptyFM mkSet le xs = listToFM le [ (x, ()) | x <- xs] isEmptySet = isEmptyFM elementOf = elemFM minusSet = minusFM setToList = keysFM union = plusFM curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/FlatCurry/000077500000000000000000000000001305333611600231435ustar00rootroot00000000000000curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/FlatCurry/Annotated/000077500000000000000000000000001305333611600250605ustar00rootroot00000000000000curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/FlatCurry/Annotated/Goodies.curry000066400000000000000000000771551305333611600275560ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- This library provides selector functions, test and update operations --- as well as some useful auxiliary functions for FlatCurry data terms. --- Most of the provided functions are based on general transformation --- functions that replace constructors with user-defined --- functions. For recursive datatypes the transformations are defined --- inductively over the term structure. This is quite usual for --- transformations on FlatCurry terms, --- so the provided functions can be used to implement specific transformations --- without having to explicitly state the recursion. Essentially, the tedious --- part of such transformations - descend in fairly complex term structures - --- is abstracted away, which hopefully makes the code more clear and brief. --- --- @author Sebastian Fischer, Bjoern Peemoeller --- @version October 2015 --- @category meta -------------------------------------------------------------------------------- module FlatCurry.Annotated.Goodies where import FlatCurry.Annotated.Types import qualified FlatCurry.Types as FC type Update a b = (b -> b) -> a -> a -- Prog ------------------------------------------------------------------------ --- transform program trProg :: (String -> [String] -> [TypeDecl] -> [AFuncDecl a] -> [OpDecl] -> b) -> AProg a -> b trProg f (AProg name imps types funcs ops) = f name imps types funcs ops -- Selectors --- get name from program progName :: AProg _ -> String progName = trProg (\name _ _ _ _ -> name) --- get imports from program progImports :: AProg _ -> [String] progImports = trProg (\_ imps _ _ _ -> imps) --- get type declarations from program progTypes :: AProg _ -> [TypeDecl] progTypes = trProg (\_ _ types _ _ -> types) --- get functions from program progFuncs :: AProg a -> [AFuncDecl a] progFuncs = trProg (\_ _ _ funcs _ -> funcs) --- get infix operators from program progOps :: AProg _ -> [OpDecl] progOps = trProg (\_ _ _ _ ops -> ops) -- Update Operations --- update program updProg :: (String -> String) -> ([String] -> [String]) -> ([TypeDecl] -> [TypeDecl]) -> ([AFuncDecl a] -> [AFuncDecl a]) -> ([OpDecl] -> [OpDecl]) -> AProg a -> AProg a updProg fn fi ft ff fo = trProg prog where prog name imps types funcs ops = AProg (fn name) (fi imps) (ft types) (ff funcs) (fo ops) --- update name of program updProgName :: Update (AProg _) String updProgName f = updProg f id id id id --- update imports of program updProgImports :: Update (AProg _) [String] updProgImports f = updProg id f id id id --- update type declarations of program updProgTypes :: Update (AProg _) [TypeDecl] updProgTypes f = updProg id id f id id --- update functions of program updProgFuncs :: Update (AProg a) [AFuncDecl a] updProgFuncs f = updProg id id id f id --- update infix operators of program updProgOps :: Update (AProg _) [OpDecl] updProgOps = updProg id id id id -- Auxiliary Functions --- get all program variables (also from patterns) allVarsInProg :: AProg _ -> [VarIndex] allVarsInProg = concatMap allVarsInFunc . progFuncs --- lift transformation on expressions to program updProgExps :: Update (AProg a) (AExpr a) updProgExps = updProgFuncs . map . updFuncBody --- rename programs variables rnmAllVarsInProg :: Update (AProg _) VarIndex rnmAllVarsInProg = updProgFuncs . map . rnmAllVarsInFunc --- update all qualified names in program updQNamesInProg :: Update (AProg _) QName updQNamesInProg f = updProg id id (map (updQNamesInType f)) (map (updQNamesInFunc f)) (map (updOpName f)) --- rename program (update name of and all qualified names in program) rnmProg :: String -> AProg a -> AProg a rnmProg name p = updProgName (const name) (updQNamesInProg rnm p) where rnm (mod,n) | mod==progName p = (name,n) | otherwise = (mod,n) -- TypeDecl ------------------------------------------------------------------ -- Selectors --- transform type declaration trType :: (QName -> Visibility -> [TVarIndex] -> [ConsDecl] -> a) -> (QName -> Visibility -> [TVarIndex] -> TypeExpr -> a) -> TypeDecl -> a trType typ _ (Type name vis params cs) = typ name vis params cs trType _ typesyn (TypeSyn name vis params syn) = typesyn name vis params syn --- get name of type declaration typeName :: TypeDecl -> QName typeName = trType (\name _ _ _ -> name) (\name _ _ _ -> name) --- get visibility of type declaration typeVisibility :: TypeDecl -> Visibility typeVisibility = trType (\_ vis _ _ -> vis) (\_ vis _ _ -> vis) --- get type parameters of type declaration typeParams :: TypeDecl -> [TVarIndex] typeParams = trType (\_ _ params _ -> params) (\_ _ params _ -> params) --- get constructor declarations from type declaration typeConsDecls :: TypeDecl -> [ConsDecl] typeConsDecls = trType (\_ _ _ cs -> cs) failed --- get synonym of type declaration typeSyn :: TypeDecl -> TypeExpr typeSyn = trType failed (\_ _ _ syn -> syn) --- is type declaration a type synonym? isTypeSyn :: TypeDecl -> Bool isTypeSyn = trType (\_ _ _ _ -> False) (\_ _ _ _ -> True) -- Update Operations --- update type declaration updType :: (QName -> QName) -> (Visibility -> Visibility) -> ([TVarIndex] -> [TVarIndex]) -> ([ConsDecl] -> [ConsDecl]) -> (TypeExpr -> TypeExpr) -> TypeDecl -> TypeDecl updType fn fv fp fc fs = trType typ typesyn where typ name vis params cs = Type (fn name) (fv vis) (fp params) (fc cs) typesyn name vis params syn = TypeSyn (fn name) (fv vis) (fp params) (fs syn) --- update name of type declaration updTypeName :: Update TypeDecl QName updTypeName f = updType f id id id id --- update visibility of type declaration updTypeVisibility :: Update TypeDecl Visibility updTypeVisibility f = updType id f id id id --- update type parameters of type declaration updTypeParams :: Update TypeDecl [TVarIndex] updTypeParams f = updType id id f id id --- update constructor declarations of type declaration updTypeConsDecls :: Update TypeDecl [ConsDecl] updTypeConsDecls f = updType id id id f id --- update synonym of type declaration updTypeSynonym :: Update TypeDecl TypeExpr updTypeSynonym = updType id id id id -- Auxiliary Functions --- update all qualified names in type declaration updQNamesInType :: Update TypeDecl QName updQNamesInType f = updType f id id (map (updQNamesInConsDecl f)) (updQNamesInTypeExpr f) -- ConsDecl ------------------------------------------------------------------ -- Selectors --- transform constructor declaration trCons :: (QName -> Int -> Visibility -> [TypeExpr] -> a) -> ConsDecl -> a trCons cons (Cons name arity vis args) = cons name arity vis args --- get name of constructor declaration consName :: ConsDecl -> QName consName = trCons (\name _ _ _ -> name) --- get arity of constructor declaration consArity :: ConsDecl -> Int consArity = trCons (\_ arity _ _ -> arity) --- get visibility of constructor declaration consVisibility :: ConsDecl -> Visibility consVisibility = trCons (\_ _ vis _ -> vis) --- get arguments of constructor declaration consArgs :: ConsDecl -> [TypeExpr] consArgs = trCons (\_ _ _ args -> args) -- Update Operations --- update constructor declaration updCons :: (QName -> QName) -> (Int -> Int) -> (Visibility -> Visibility) -> ([TypeExpr] -> [TypeExpr]) -> ConsDecl -> ConsDecl updCons fn fa fv fas = trCons cons where cons name arity vis args = Cons (fn name) (fa arity) (fv vis) (fas args) --- update name of constructor declaration updConsName :: Update ConsDecl QName updConsName f = updCons f id id id --- update arity of constructor declaration updConsArity :: Update ConsDecl Int updConsArity f = updCons id f id id --- update visibility of constructor declaration updConsVisibility :: Update ConsDecl Visibility updConsVisibility f = updCons id id f id --- update arguments of constructor declaration updConsArgs :: Update ConsDecl [TypeExpr] updConsArgs = updCons id id id -- Auxiliary Functions --- update all qualified names in constructor declaration updQNamesInConsDecl :: Update ConsDecl QName updQNamesInConsDecl f = updCons f id id (map (updQNamesInTypeExpr f)) -- TypeExpr ------------------------------------------------------------------ -- Selectors --- get index from type variable tVarIndex :: TypeExpr -> TVarIndex tVarIndex texpr = case texpr of (TVar n) -> n _ -> error "AnnotatedFlatCurryGoodies.tVarIndex: no type variable" --- get domain from functional type domain :: TypeExpr -> TypeExpr domain texpr = case texpr of (FuncType dom _) -> dom _ -> error "AnnotatedFlatCurryGoodies.domain: no functional type" --- get range from functional type range :: TypeExpr -> TypeExpr range texpr = case texpr of (FuncType _ ran) -> ran _ -> error "AnnotatedFlatCurryGoodies.range: no functional type" --- get name from constructed type tConsName :: TypeExpr -> QName tConsName texpr = case texpr of (TCons name _) -> name _ -> error "AnnotatedFlatCurryGoodies.tConsName: no functional type" --- get arguments from constructed type tConsArgs :: TypeExpr -> [TypeExpr] tConsArgs texpr = case texpr of (TCons _ args) -> args _ -> error "AnnotatedFlatCurryGoodies.tConsArgs: no functional type" --- transform type expression trTypeExpr :: (TVarIndex -> a) -> (QName -> [a] -> a) -> (a -> a -> a) -> TypeExpr -> a trTypeExpr tvar _ _ (TVar n) = tvar n trTypeExpr tvar tcons functype (TCons name args) = tcons name (map (trTypeExpr tvar tcons functype) args) trTypeExpr tvar tcons functype (FuncType from to) = functype (f from) (f to) where f = trTypeExpr tvar tcons functype -- Test Operations --- is type expression a type variable? isTVar :: TypeExpr -> Bool isTVar = trTypeExpr (\_ -> True) (\_ _ -> False) (\_ _ -> False) --- is type declaration a constructed type? isTCons :: TypeExpr -> Bool isTCons = trTypeExpr (\_ -> False) (\_ _ -> True) (\_ _ -> False) --- is type declaration a functional type? isFuncType :: TypeExpr -> Bool isFuncType = trTypeExpr (\_ -> False) (\_ _ -> False) (\_ _ -> True) -- Update Operations --- update all type variables updTVars :: (TVarIndex -> TypeExpr) -> TypeExpr -> TypeExpr updTVars tvar = trTypeExpr tvar TCons FuncType --- update all type constructors updTCons :: (QName -> [TypeExpr] -> TypeExpr) -> TypeExpr -> TypeExpr updTCons tcons = trTypeExpr TVar tcons FuncType --- update all functional types updFuncTypes :: (TypeExpr -> TypeExpr -> TypeExpr) -> TypeExpr -> TypeExpr updFuncTypes = trTypeExpr TVar TCons -- Auxiliary Functions --- get argument types from functional type argTypes :: TypeExpr -> [TypeExpr] argTypes (TVar _) = [] argTypes (TCons _ _) = [] argTypes (FuncType dom ran) = dom : argTypes ran --- get result type from (nested) functional type resultType :: TypeExpr -> TypeExpr resultType (TVar n) = TVar n resultType (TCons name args) = TCons name args resultType (FuncType _ ran) = resultType ran --- rename variables in type expression rnmAllVarsInTypeExpr :: (TVarIndex -> TVarIndex) -> TypeExpr -> TypeExpr rnmAllVarsInTypeExpr f = updTVars (TVar . f) --- update all qualified names in type expression updQNamesInTypeExpr :: (QName -> QName) -> TypeExpr -> TypeExpr updQNamesInTypeExpr f = updTCons (\name args -> TCons (f name) args) -- OpDecl -------------------------------------------------------------------- --- transform operator declaration trOp :: (QName -> Fixity -> Int -> a) -> OpDecl -> a trOp op (Op name fix prec) = op name fix prec -- Selectors --- get name from operator declaration opName :: OpDecl -> QName opName = trOp (\name _ _ -> name) --- get fixity of operator declaration opFixity :: OpDecl -> Fixity opFixity = trOp (\_ fix _ -> fix) --- get precedence of operator declaration opPrecedence :: OpDecl -> Int opPrecedence = trOp (\_ _ prec -> prec) -- Update Operations --- update operator declaration updOp :: (QName -> QName) -> (Fixity -> Fixity) -> (Int -> Int) -> OpDecl -> OpDecl updOp fn ff fp = trOp op where op name fix prec = Op (fn name) (ff fix) (fp prec) --- update name of operator declaration updOpName :: Update OpDecl QName updOpName f = updOp f id id --- update fixity of operator declaration updOpFixity :: Update OpDecl Fixity updOpFixity f = updOp id f id --- update precedence of operator declaration updOpPrecedence :: Update OpDecl Int updOpPrecedence = updOp id id -- FuncDecl -------------------------------------------------------------------- --- transform function trFunc :: (QName -> Int -> Visibility -> TypeExpr -> ARule a -> b) -> AFuncDecl a -> b trFunc func (AFunc name arity vis t rule) = func name arity vis t rule -- Selectors --- get name of function funcName :: AFuncDecl _ -> QName funcName = trFunc (\name _ _ _ _ -> name) --- get arity of function funcArity :: AFuncDecl _ -> Int funcArity = trFunc (\_ arity _ _ _ -> arity) --- get visibility of function funcVisibility :: AFuncDecl _ -> Visibility funcVisibility = trFunc (\_ _ vis _ _ -> vis) --- get type of function funcType :: AFuncDecl _ -> TypeExpr funcType = trFunc (\_ _ _ t _ -> t) --- get rule of function funcRule :: AFuncDecl a -> ARule a funcRule = trFunc (\_ _ _ _ rule -> rule) -- Update Operations --- update function updFunc :: (QName -> QName) -> (Int -> Int) -> (Visibility -> Visibility) -> (TypeExpr -> TypeExpr) -> (ARule a -> ARule a) -> AFuncDecl a -> AFuncDecl a updFunc fn fa fv ft fr = trFunc func where func name arity vis t rule = AFunc (fn name) (fa arity) (fv vis) (ft t) (fr rule) --- update name of function updFuncName :: Update (AFuncDecl _) QName updFuncName f = updFunc f id id id id --- update arity of function updFuncArity :: Update (AFuncDecl _) Int updFuncArity f = updFunc id f id id id --- update visibility of function updFuncVisibility :: Update (AFuncDecl _) Visibility updFuncVisibility f = updFunc id id f id id --- update type of function updFuncType :: Update (AFuncDecl _) TypeExpr updFuncType f = updFunc id id id f id --- update rule of function updFuncRule :: Update (AFuncDecl a) (ARule a) updFuncRule = updFunc id id id id -- Auxiliary Functions --- is function externally defined? isExternal :: AFuncDecl _ -> Bool isExternal = isRuleExternal . funcRule --- get variable names in a function declaration allVarsInFunc :: AFuncDecl _ -> [VarIndex] allVarsInFunc = allVarsInRule . funcRule --- get arguments of function, if not externally defined funcArgs :: AFuncDecl a -> [(VarIndex, a)] funcArgs = ruleArgs . funcRule --- get body of function, if not externally defined funcBody :: AFuncDecl a -> AExpr a funcBody = ruleBody . funcRule funcRHS :: AFuncDecl a -> [AExpr a] funcRHS f | not (isExternal f) = orCase (funcBody f) | otherwise = [] where orCase e | isOr e = concatMap orCase (orExps e) | isCase e = concatMap orCase (map branchExpr (caseBranches e)) | otherwise = [e] --- rename all variables in function rnmAllVarsInFunc :: Update (AFuncDecl _) VarIndex rnmAllVarsInFunc = updFunc id id id id . rnmAllVarsInRule --- update all qualified names in function updQNamesInFunc :: Update (AFuncDecl _) QName updQNamesInFunc f = updFunc f id id (updQNamesInTypeExpr f) (updQNamesInRule f) --- update arguments of function, if not externally defined updFuncArgs :: Update (AFuncDecl a) [(VarIndex, a)] updFuncArgs = updFuncRule . updRuleArgs --- update body of function, if not externally defined updFuncBody :: Update (AFuncDecl a) (AExpr a) updFuncBody = updFuncRule . updRuleBody -- Rule ------------------------------------------------------------------------ --- transform rule trRule :: (a -> [(VarIndex, a)] -> AExpr a -> b) -> (a -> String -> b) -> ARule a -> b trRule rule _ (ARule a vs e) = rule a vs e trRule _ ext (AExternal a s) = ext a s -- Selectors --- get rules arguments if it's not external ruleArgs :: ARule a -> [(VarIndex, a)] ruleArgs = trRule (\_ vs _ -> vs) failed --- get rules body if it's not external ruleBody :: ARule a -> AExpr a ruleBody = trRule (\_ _ e -> e) failed --- get rules external declaration ruleExtDecl :: ARule _ -> String ruleExtDecl = trRule failed (\_ s -> s) -- Test Operations --- is rule external? isRuleExternal :: ARule _ -> Bool isRuleExternal = trRule (\_ _ _ -> False) (\_ _ -> True) -- Update Operations --- update rule updRule :: (a -> a) -> ([(VarIndex, a)] -> [(VarIndex, a)]) -> (AExpr a -> AExpr a) -> (String -> String) -> ARule a -> ARule a updRule fa fvs fe fs = trRule rule ext where rule a vs e = ARule (fa a) (fvs vs) (fe e) ext a s = AExternal (fa a) (fs s) --- update rules arguments updRuleArgs :: Update (ARule a) [(VarIndex, a)] updRuleArgs f = updRule id f id id --- update rules body updRuleBody :: Update (ARule a) (AExpr a) updRuleBody f = updRule id id f id --- update rules external declaration updRuleExtDecl :: Update (ARule _) String updRuleExtDecl f = updRule id id id f -- Auxiliary Functions --- get variable names in a functions rule allVarsInRule :: ARule _ -> [VarIndex] allVarsInRule = trRule (\_ vs e -> map fst vs ++ allVars e) (\_ _ -> []) --- rename all variables in rule rnmAllVarsInRule :: Update (ARule _) VarIndex rnmAllVarsInRule f = updRule id (map (\(v,a) -> (f v, a))) (rnmAllVars f) id --- update all qualified names in rule updQNamesInRule :: Update (ARule _) QName updQNamesInRule = updRuleBody . updQNames -- CombType -------------------------------------------------------------------- --- transform combination type trCombType :: a -> (Int -> a) -> a -> (Int -> a) -> CombType -> a trCombType fc _ _ _ FuncCall = fc trCombType _ fpc _ _ (FuncPartCall n) = fpc n trCombType _ _ cc _ ConsCall = cc trCombType _ _ _ cpc (ConsPartCall n) = cpc n -- Test Operations --- is type of combination FuncCall? isCombTypeFuncCall :: CombType -> Bool isCombTypeFuncCall = trCombType True (\_ -> False) False (\_ -> False) --- is type of combination FuncPartCall? isCombTypeFuncPartCall :: CombType -> Bool isCombTypeFuncPartCall = trCombType False (\_ -> True) False (\_ -> False) --- is type of combination ConsCall? isCombTypeConsCall :: CombType -> Bool isCombTypeConsCall = trCombType False (\_ -> False) True (\_ -> False) --- is type of combination ConsPartCall? isCombTypeConsPartCall :: CombType -> Bool isCombTypeConsPartCall = trCombType False (\_ -> False) False (\_ -> True) -- Auxiliary Functions missingArgs :: CombType -> Int missingArgs = trCombType 0 id 0 id -- Expr ------------------------------------------------------------------------ -- Selectors --- get internal number of variable varNr :: AExpr _ -> VarIndex varNr aexpr = case aexpr of (AVar _ n) -> n _ -> error "AnnotatedFlatCurryGoodies.varNr: no variable" --- get literal if expression is literal expression literal :: AExpr _ -> Literal literal aexpr = case aexpr of (ALit _ l) -> l _ -> error "AnnotatedFlatCurryGoodies.literal: no literal" --- get combination type of a combined expression combType :: AExpr _ -> CombType combType aexpr = case aexpr of (AComb _ ct _ _) -> ct _ -> error "AnnotatedFlatCurryGoodies.combType: no combined expression" --- get name of a combined expression combName :: AExpr _ -> QName combName aexpr = case aexpr of (AComb _ _ name _) -> fst name _ -> error "AnnotatedFlatCurryGoodies.combName: no combined expression" --- get arguments of a combined expression combArgs :: AExpr a -> [AExpr a] combArgs aexpr = case aexpr of (AComb _ _ _ args) -> args _ -> error "AnnotatedFlatCurryGoodies.combArgs: no combined expression" --- get number of missing arguments if expression is combined missingCombArgs :: AExpr _ -> Int missingCombArgs = missingArgs . combType --- get indices of variables in let declaration letBinds :: AExpr a -> [((VarIndex, a), AExpr a)] letBinds aexpr = case aexpr of (ALet _ vs _) -> vs _ -> error "AnnotatedFlatCurryGoodies.letBinds: no let declaration" --- get body of let declaration letBody :: AExpr a -> AExpr a letBody aexpr = case aexpr of (ALet _ _ e) -> e _ -> error "AnnotatedFlatCurryGoodies.letBody: no let declaration" --- get variable indices from declaration of free variables freeVars :: AExpr _ -> [VarIndex] freeVars aexpr = case aexpr of (AFree _ vs _) -> map fst vs _ -> error "AnnotatedFlatCurryGoodies.freeVars: no free variable declaration" --- get expression from declaration of free variables freeExpr :: AExpr a -> AExpr a freeExpr aexpr = case aexpr of (AFree _ _ e) -> e _ -> error "AnnotatedFlatCurryGoodies.freeExpr: no free variable declaration" --- get expressions from or-expression orExps :: AExpr a -> [AExpr a] orExps aexpr = case aexpr of (AOr _ e1 e2) -> [e1,e2] _ -> error "AnnotatedFlatCurryGoodies.orExps: no or-expression" --- get case-type of case expression caseType :: AExpr _ -> CaseType caseType aexpr = case aexpr of (ACase _ ct _ _) -> ct _ -> error "AnnotatedFlatCurryGoodies.caseType: no case expression" --- get scrutinee of case expression caseExpr :: AExpr a -> AExpr a caseExpr aexpr = case aexpr of (ACase _ _ e _) -> e _ -> error "AnnotatedFlatCurryGoodies.caseExpr: no case expression" --- get branch expressions from case expression caseBranches :: AExpr a -> [ABranchExpr a] caseBranches aexpr = case aexpr of (ACase _ _ _ bs) -> bs _ -> error "AnnotatedFlatCurryGoodies.caseBranches: no case expression" -- Test Operations --- is expression a variable? isVar :: AExpr _ -> Bool isVar e = case e of AVar _ _ -> True _ -> False --- is expression a literal expression? isLit :: AExpr _ -> Bool isLit e = case e of ALit _ _ -> True _ -> False --- is expression combined? isComb :: AExpr _ -> Bool isComb e = case e of AComb _ _ _ _ -> True _ -> False --- is expression a let expression? isLet :: AExpr _ -> Bool isLet e = case e of ALet _ _ _ -> True _ -> False --- is expression a declaration of free variables? isFree :: AExpr _ -> Bool isFree e = case e of AFree _ _ _ -> True _ -> False --- is expression an or-expression? isOr :: AExpr _ -> Bool isOr e = case e of AOr _ _ _ -> True _ -> False --- is expression a case expression? isCase :: AExpr _ -> Bool isCase e = case e of ACase _ _ _ _ -> True _ -> False --- transform expression trExpr :: (a -> VarIndex -> b) -> (a -> Literal -> b) -> (a -> CombType -> (QName, a) -> [b] -> b) -> (a -> [((VarIndex, a), b)] -> b -> b) -> (a -> [(VarIndex, a)] -> b -> b) -> (a -> b -> b -> b) -> (a -> CaseType -> b -> [c] -> b) -> (APattern a -> b -> c) -> (a -> b -> TypeExpr -> b) -> AExpr a -> b trExpr var _ _ _ _ _ _ _ _ (AVar a n) = var a n trExpr _ lit _ _ _ _ _ _ _ (ALit a l) = lit a l trExpr var lit comb lt fr or cas branch typed (AComb a ct name args) = comb a ct name (map (trExpr var lit comb lt fr or cas branch typed) args) trExpr var lit comb lt fr or cas branch typed (ALet a bs e) = lt a (map (\ (n,exp) -> (n,f exp)) bs) (f e) where f = trExpr var lit comb lt fr or cas branch typed trExpr var lit comb lt fr or cas branch typed (AFree a vs e) = fr a vs (trExpr var lit comb lt fr or cas branch typed e) trExpr var lit comb lt fr or cas branch typed (AOr a e1 e2) = or a (f e1) (f e2) where f = trExpr var lit comb lt fr or cas branch typed trExpr var lit comb lt fr or cas branch typed (ACase a ct e bs) = cas a ct (f e) (map (\ (ABranch pat exp) -> branch pat (f exp)) bs) where f = trExpr var lit comb lt fr or cas branch typed trExpr var lit comb lt fr or cas branch typed (ATyped a e ty) = typed a (trExpr var lit comb lt fr or cas branch typed e) ty -- Update Operations --- update all variables in given expression updVars :: (a -> VarIndex -> AExpr a) -> AExpr a -> AExpr a updVars var = trExpr var ALit AComb ALet AFree AOr ACase ABranch ATyped --- update all literals in given expression updLiterals :: (a -> Literal -> AExpr a) -> AExpr a -> AExpr a updLiterals lit = trExpr AVar lit AComb ALet AFree AOr ACase ABranch ATyped --- update all combined expressions in given expression updCombs :: (a -> CombType -> (QName, a) -> [AExpr a] -> AExpr a) -> AExpr a -> AExpr a updCombs comb = trExpr AVar ALit comb ALet AFree AOr ACase ABranch ATyped --- update all let expressions in given expression updLets :: (a -> [((VarIndex, a), AExpr a)] -> AExpr a -> AExpr a) -> AExpr a -> AExpr a updLets lt = trExpr AVar ALit AComb lt AFree AOr ACase ABranch ATyped --- update all free declarations in given expression updFrees :: (a -> [(VarIndex, a)] -> AExpr a -> AExpr a) -> AExpr a -> AExpr a updFrees fr = trExpr AVar ALit AComb ALet fr AOr ACase ABranch ATyped --- update all or expressions in given expression updOrs :: (a -> AExpr a -> AExpr a -> AExpr a) -> AExpr a -> AExpr a updOrs or = trExpr AVar ALit AComb ALet AFree or ACase ABranch ATyped --- update all case expressions in given expression updCases :: (a -> CaseType -> AExpr a -> [ABranchExpr a] -> AExpr a) -> AExpr a -> AExpr a updCases cas = trExpr AVar ALit AComb ALet AFree AOr cas ABranch ATyped --- update all case branches in given expression updBranches :: (APattern a -> AExpr a -> ABranchExpr a) -> AExpr a -> AExpr a updBranches branch = trExpr AVar ALit AComb ALet AFree AOr ACase branch ATyped --- update all typed expressions in given expression updTypeds :: (a -> AExpr a -> TypeExpr -> AExpr a) -> AExpr a -> AExpr a updTypeds typed = trExpr AVar ALit AComb ALet AFree AOr ACase ABranch typed -- Auxiliary Functions --- is expression a call of a function where all arguments are provided? isFuncCall :: AExpr _ -> Bool isFuncCall e = isComb e && isCombTypeFuncCall (combType e) --- is expression a partial function call? isFuncPartCall :: AExpr _ -> Bool isFuncPartCall e = isComb e && isCombTypeFuncPartCall (combType e) --- is expression a call of a constructor? isConsCall :: AExpr _ -> Bool isConsCall e = isComb e && isCombTypeConsCall (combType e) --- is expression a partial constructor call? isConsPartCall :: AExpr _ -> Bool isConsPartCall e = isComb e && isCombTypeConsPartCall (combType e) --- is expression fully evaluated? isGround :: AExpr _ -> Bool isGround exp = case exp of AComb _ ConsCall _ args -> all isGround args _ -> isLit exp --- get all variables (also pattern variables) in expression allVars :: AExpr _ -> [VarIndex] allVars e = trExpr var lit comb lt fr or cas branch typed e [] where var _ = (:) lit _ = const id comb _ _ _ = foldr (.) id lt _ bs exp = exp . foldr (.) id (map (\ ((n, _), ns) -> (n:) . ns) bs) fr _ vs exp = (map fst vs ++) . exp or _ = (.) cas _ _ exp bs = exp . foldr (.) id bs branch pat exp = (args pat ++) . exp args pat | isConsPattern pat = map fst (patArgs pat) | otherwise = [] typed _ = const --- rename all variables (also in patterns) in expression rnmAllVars :: Update (AExpr _) VarIndex rnmAllVars f = trExpr var ALit AComb lt fre AOr ACase branch ATyped where var a = AVar a . f fre a vs b = AFree a (map (\(v, x) -> (f v, x)) vs) b lt a = ALet a . map (\ ((n, x), exp) -> ((f n, x),exp)) branch = ABranch . updPatArgs (map (\(v, a) -> (f v, a))) --- update all qualified names in expression updQNames :: Update (AExpr _) QName updQNames f = trExpr AVar ALit comb ALet AFree AOr ACase branch typed where comb a ct (name, b) args = AComb a ct (f name, b) args branch = ABranch . updPatCons f typed a e ty = ATyped a e (updQNamesInTypeExpr f ty) -- BranchExpr ---------------------------------------------------------------- --- transform branch expression trBranch :: (APattern a -> AExpr a -> b) -> ABranchExpr a -> b trBranch branch (ABranch pat exp) = branch pat exp -- Selectors --- get pattern from branch expression branchPattern :: ABranchExpr a -> APattern a branchPattern = trBranch (\pat _ -> pat) --- get expression from branch expression branchExpr :: ABranchExpr a -> AExpr a branchExpr = trBranch (\_ e -> e) -- Update Operations --- update branch expression updBranch :: (APattern a -> APattern a) -> (AExpr a -> AExpr a) -> ABranchExpr a -> ABranchExpr a updBranch fp fe = trBranch branch where branch pat exp = ABranch (fp pat) (fe exp) --- update pattern of branch expression updBranchPattern :: Update (ABranchExpr a) (APattern a) updBranchPattern f = updBranch f id --- update expression of branch expression updBranchExpr :: Update (ABranchExpr a) (AExpr a) updBranchExpr = updBranch id -- Pattern ------------------------------------------------------------------- --- transform pattern trPattern :: (a -> (QName, a) -> [(VarIndex, a)] -> b) -> (a -> Literal -> b) -> APattern a -> b trPattern pattern _ (APattern a name args) = pattern a name args trPattern _ lpattern (ALPattern a l) = lpattern a l -- Selectors --- get name from constructor pattern patCons :: APattern _ -> QName patCons = trPattern (\_ name _ -> fst name) failed --- get arguments from constructor pattern patArgs :: APattern a -> [(VarIndex, a)] patArgs = trPattern (\_ _ args -> args) failed --- get literal from literal pattern patLiteral :: APattern _ -> Literal patLiteral = trPattern failed (\_ l -> l) -- Test Operations --- is pattern a constructor pattern? isConsPattern :: APattern _ -> Bool isConsPattern = trPattern (\ _ _ _ -> True) (\ _ _ -> False) -- Update Operations --- update pattern updPattern :: ((QName, a) -> (QName, a)) -> ([(VarIndex, a)] -> [(VarIndex, a)]) -> (Literal -> Literal) -> APattern a -> APattern a updPattern fn fa fl = trPattern apattern alpattern where apattern a name args = APattern a (fn name) (fa args) alpattern a l = ALPattern a (fl l) --- update constructors name of pattern updPatCons :: (QName -> QName) -> APattern a -> APattern a updPatCons f = updPattern (\(n,a) -> (f n, a)) id id --- update arguments of constructor pattern updPatArgs :: ([(VarIndex, a)] -> [(VarIndex, a)]) -> APattern a -> APattern a updPatArgs f = updPattern id f id --- update literal of pattern updPatLiteral :: (Literal -> Literal) -> APattern a -> APattern a updPatLiteral f = updPattern id id f -- Auxiliary Functions --- build expression from pattern patExpr :: APattern a -> AExpr a patExpr = trPattern (\a name vs -> AComb a ConsCall name (map var vs)) ALit where var (v, a) = AVar a v -- Retrieval of the annotation annRule :: ARule a -> a annRule (ARule a _ _) = a annRule (AExternal a _) = a --- Extract the annotation of an annotated expression. annExpr :: AExpr a -> a annExpr (AComb a _ _ _) = a annExpr (ACase a _ _ _) = a annExpr (AVar a _ ) = a annExpr (ALit a _ ) = a annExpr (AOr a _ _ ) = a annExpr (ALet a _ _ ) = a annExpr (AFree a _ _ ) = a annExpr (ATyped a _ _ ) = a --- Extract the annotation of an annotated pattern. annPattern :: APattern a -> a annPattern (APattern a _ _) = a annPattern (ALPattern a _ ) = a -- Remove annotation unAnnProg :: AProg _ -> FC.Prog unAnnProg = trProg (\m is ts fs os -> FC.Prog m is ts (map unAnnFuncDecl fs) os) unAnnFuncDecl :: AFuncDecl _ -> FC.FuncDecl unAnnFuncDecl = trFunc (\f ar vs ty r -> FC.Func f ar vs ty (unAnnRule r)) unAnnRule :: ARule _ -> FC.Rule unAnnRule = trRule (\_ vs e -> FC.Rule (map fst vs) (unAnnExpr e)) (\_ s -> FC.External s) unAnnExpr :: AExpr _ -> FC.Expr unAnnExpr = trExpr var lit comb lett fre or cse branch typed where var _ v = FC.Var v lit _ l = FC.Lit l comb _ ct n es = FC.Comb ct (fst n) es lett _ bs e = FC.Let (map (\((v, _), b) -> (v, b)) bs) e fre _ vs e = FC.Free (map fst vs) e or _ a b = FC.Or a b cse _ ct e bs = FC.Case ct e bs branch p e = FC.Branch (unAnnPattern p) e typed _ e ty = FC.Typed e ty unAnnPattern :: APattern _ -> FC.Pattern unAnnPattern = trPattern (\_ qn vs -> FC.Pattern (fst qn) (map fst vs)) (\_ l -> FC.LPattern l) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/FlatCurry/Annotated/Pretty.curry000066400000000000000000000217511305333611600274430ustar00rootroot00000000000000--- -------------------------------------------------------------------------- --- This library provides pretty-printers for AnnotatedFlatCurry modules --- and all substructures (e.g., expressions). Note that annotations are --- ignored for pretty-printing. --- --- @author Bjoern Peemoeller --- @version October 2015 --- @category meta --- -------------------------------------------------------------------------- module FlatCurry.Annotated.Pretty where import Pretty import FlatCurry.Annotated.Types --- pretty-print a FlatCurry module ppProg :: AProg _ -> Doc ppProg (AProg m is ts fs os) = compose (<$+$>) [ ppHeader m ts fs , ppImports is , ppOpDecls os , ppTypeDecls ts , ppFuncDecls fs ] --- pretty-print the module header ppHeader :: String -> [TypeDecl] -> [AFuncDecl _] -> Doc ppHeader m ts fs = indent $ sep [text "module" <+> text m, ppExports ts fs, text "where"] --- pretty-print the export list ppExports :: [TypeDecl] -> [AFuncDecl _] -> Doc ppExports ts fs = tupledSpaced (map ppTypeExport ts ++ ppFuncExports fs) --- pretty-print a type export ppTypeExport :: TypeDecl -> Doc ppTypeExport (Type qn vis _ cs) | vis == Private = empty | all isPublicCons cs = ppPrefixOp qn <+> text "(..)" | otherwise = ppPrefixOp qn <+> tupled (ppConsExports cs) where isPublicCons (Cons _ _ v _) = v == Public ppTypeExport (TypeSyn qn vis _ _ ) | vis == Private = empty | otherwise = ppPrefixOp qn --- pretty-print the export list of constructors ppConsExports :: [ConsDecl] -> [Doc] ppConsExports cs = [ ppPrefixOp qn | Cons qn _ Public _ <- cs] --- pretty-print the export list of functions ppFuncExports :: [AFuncDecl _] -> [Doc] ppFuncExports fs = [ ppPrefixOp qn | AFunc qn _ Public _ _ <- fs] --- pretty-print a list of import statements ppImports :: [String] -> Doc ppImports = vsep . map ppImport --- pretty-print a single import statement ppImport :: String -> Doc ppImport m = indent $ text "import" <+> text m --- pretty-print a list of operator fixity declarations ppOpDecls :: [OpDecl] -> Doc ppOpDecls = vsep . map ppOpDecl --- pretty-print a single operator fixity declaration ppOpDecl :: OpDecl -> Doc ppOpDecl (Op qn fix n) = indent $ ppFixity fix <+> int n <+> ppInfixOp qn --- pretty-print the associativity keyword ppFixity :: Fixity -> Doc ppFixity InfixOp = text "infix" ppFixity InfixlOp = text "infixl" ppFixity InfixrOp = text "infixr" --- pretty-print a list of type declarations ppTypeDecls :: [TypeDecl] -> Doc ppTypeDecls = compose (<$+$>) . map ppTypeDecl --- pretty-print a type declaration ppTypeDecl :: TypeDecl -> Doc ppTypeDecl (Type qn _ vs cs) = indent $ text "data" <+> ppQName qn <+> hsep (map ppTVarIndex vs) <$$> ppConsDecls cs ppTypeDecl (TypeSyn qn _ vs ty) = indent $ text "type" <+> ppQName qn <+> hsep (map ppTVarIndex vs) equals <+> ppTypeExp ty --- pretty-print the constructor declarations ppConsDecls :: [ConsDecl] -> Doc ppConsDecls cs = vsep $ zipWith (<+>) (equals : repeat bar) (map ppConsDecl cs) --- pretty print a single constructor ppConsDecl :: ConsDecl -> Doc ppConsDecl (Cons qn _ _ tys) = hsep $ ppPrefixOp qn : map (ppTypeExpr 2) tys --- pretty a top-level type expression ppTypeExp :: TypeExpr -> Doc ppTypeExp = ppTypeExpr 0 --- pretty-print a type expression ppTypeExpr :: Int -> TypeExpr -> Doc ppTypeExpr _ (TVar v) = ppTVarIndex v ppTypeExpr p (FuncType ty1 ty2) = parensIf (p > 0) $ ppTypeExpr 1 ty1 rarrow <+> ppTypeExp ty2 ppTypeExpr p (TCons qn tys) | isListId qn && length tys == 1 = brackets (ppTypeExp (head tys)) | isTupleId qn = tupled (map ppTypeExp tys) | otherwise = parensIf (p > 1 && not (null tys)) $ sep (ppPrefixOp qn : map (ppTypeExpr 2) tys) --- pretty-print a type variable ppTVarIndex :: TVarIndex -> Doc ppTVarIndex i = text $ vars !! i where vars = [ chr c : if n == 0 then [] else show n | n <- [0 ..], c <- [ord 'a' .. ord 'z'] ] --- pretty-print a list of function declarations ppFuncDecls :: [AFuncDecl _] -> Doc ppFuncDecls = compose (<$+$>) . map ppFuncDecl --- pretty-print a function declaration ppFuncDecl :: AFuncDecl _ -> Doc ppFuncDecl (AFunc qn _ _ ty r) = indent (sep [ppPrefixOp qn, text "::", ppTypeExp ty]) <$$> indent (ppPrefixOp qn <+> ppRule r) --- pretty-print a function rule ppRule :: ARule _ -> Doc ppRule (ARule _ vs e) | null vs = equals <+> ppExp e | otherwise = hsep (map ppAVarIndex vs) equals <+> ppExp e ppRule (AExternal _ e) = text "external" <+> dquotes (text e) --- pretty-print a top-level expression ppExp :: AExpr _ -> Doc ppExp = ppExpr 0 --- pretty-print an expression ppExpr :: Int -> AExpr _ -> Doc ppExpr _ (AVar _ v) = ppVarIndex v ppExpr _ (ALit _ l) = ppLiteral l ppExpr p (AComb _ _ qn es) = ppComb p qn es ppExpr p (AFree _ vs e) | null vs = ppExpr p e | otherwise = parensIf (p > 0) $ sep [ text "let" <+> encloseSep empty empty comma (map ppAVarIndex vs) <+> text "free" , text "in" ppExp e ] ppExpr p (ALet _ ds e) = parensIf (p > 0) $ sep [text "let" <+> ppDecls ds, text "in" <+> ppExp e] ppExpr p (AOr _ e1 e2) = parensIf (p > 0) $ ppExpr 1 e1 <+> text "?" <+> ppExpr 1 e2 ppExpr p (ACase _ ct e bs) = parensIf (p > 0) $ indent $ ppCaseType ct <+> ppExpr 1 e <+> text "of" <$$> vsep (map ppBranch bs) ppExpr p (ATyped _ e ty) = parensIf (p > 0) $ ppExp e <+> text "::" <+> ppTypeExp ty --- pretty-print an annotated variable ppAVarIndex :: (VarIndex, _) -> Doc ppAVarIndex (i, _) | i < 0 = text $ 'x' : show (negate i) | otherwise = text $ 'v' : show i --- pretty-print a variable ppVarIndex :: VarIndex -> Doc ppVarIndex i | i < 0 = text $ 'x' : show (negate i) | otherwise = text $ 'v' : show i --- pretty-print a literal ppLiteral :: Literal -> Doc ppLiteral (Intc i) = int i ppLiteral (Floatc f) = float f ppLiteral (Charc c) = text (showEscape c) --- Escape character literal showEscape :: Char -> String showEscape c | o < 10 = "'\\00" ++ show o ++ "'" | o < 32 = "'\\0" ++ show o ++ "'" | o == 127 = "'\\127'" | otherwise = show c where o = ord c --- Pretty print a constructor or function call ppComb :: Int -> (QName, _) -> [AExpr _] -> Doc ppComb p (qn, _) es | isListId qn && null es = text "[]" | isTupleId qn = tupled (map ppExp es) | otherwise = case es of [] -> ppPrefixOp qn [e1,e2] | isInfixOp qn -> parensIf (p > 0) $ sep [ppExpr 1 e1, ppInfixOp qn, ppExpr 1 e2] _ -> parensIf (p > 0) $ sep (ppPrefixOp qn : map (ppExpr 1) es) --- pretty-print a list of declarations ppDecls :: [((VarIndex, _), AExpr _)] -> Doc ppDecls = semiBracesSpaced . map ppDecl --- pretty-print a single declaration ppDecl :: ((VarIndex, _), AExpr _) -> Doc ppDecl (v, e) = ppAVarIndex v <+> equals <+> ppExp e --- Pretty print the type of a case expression ppCaseType :: CaseType -> Doc ppCaseType Rigid = text "case" ppCaseType Flex = text "fcase" --- Pretty print a case branch ppBranch :: ABranchExpr _ -> Doc ppBranch (ABranch p e) = ppPattern p <+> rarrow <+> indent (ppExp e) --- Pretty print a pattern ppPattern :: APattern _ -> Doc ppPattern (APattern _ (c, _) vs) | isListId c && null vs = text "[]" | isTupleId c = tupled (map ppAVarIndex vs) | otherwise = case vs of [v1,v2] | isInfixOp c -> ppAVarIndex v1 <+> ppInfixOp c <+> ppAVarIndex v2 _ -> hsep (ppPrefixOp c : map ppAVarIndex vs) ppPattern (ALPattern _ l) = ppLiteral l --- pretty-print a prefix operator ppPrefixOp :: QName -> Doc ppPrefixOp qn = parensIf (isInfixOp qn) (ppQName qn) --- pretty-print an infix operator ppInfixOp :: QName -> Doc ppInfixOp qn = if isInfixOp qn then ppQName qn else bquotes (ppQName qn) --- Pretty-print a qualified name ppQName :: QName -> Doc ppQName (m, i) | m == "Prelude" && i `elem` builtin = text i | otherwise = text $ m ++ '.' : i where builtin = [ "[]", "?", ":", "+", "-", "*", "<" , ">", "<=", ">=", "==", "/=", "&>", "&" ] --- Check whether an operator is an infix operator isInfixOp :: QName -> Bool isInfixOp = all (`elem` "~!@#$%^&*+-=<>:?./|\\") . snd --- Check whether an identifier represents a list isListId :: QName -> Bool isListId (m, i) = m `elem` ["Prelude", ""] && i == "[]" --- Check whether an identifier represents a tuple isTupleId :: QName -> Bool isTupleId (m, i) = m `elem` ["Prelude", ""] && i == mkTuple (length i) where mkTuple n = '(' : replicate (n - 2) ',' ++ ")" --- Indentation indent :: Doc -> Doc indent = nest 2 curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/FlatCurry/Annotated/TypeInference.curry000066400000000000000000000735461305333611600307250ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library to annotate the expressions of a FlatCurry program --- with type information. --- --- It can be used by any other Curry program which processes --- or transforms FlatCurry programs. The main operation to use is --- --- inferProg :: Prog -> IO (Either String (AProg TypeExpr)) --- --- which annotates a FlatCurry program with type information. --- --- The type inference works in several steps: --- --- 1. For each known function and constructor, either imported or defined --- in the module itself, the respective type is inserted into a type --- environment (type assumption). --- --- 2. Every subexpression is annotated with a fresh type variable, whereas --- constructor and function names are annotated with a fresh variant of --- the type in the type assumption. --- --- 3. Based on FlatCurry's type inference rules, type equations are generated --- for a function's rule. --- --- 4. The resulting equations are solved using unification and the --- resulting substitution is applied to the function rule. --- --- 5. The inferred types are then normalized such that for every function --- rule the type variables start with 0. --- --- In addition, the function `inferNewFunctions` allows to infer the types --- of a list of functions whose type is not known before. Consequently, --- this disallows polymorphic recursive functions. Those functions are --- separated into strongly connected components before their types are inferred --- to allow mutually recursive function definitions. --- --- In case of any error, the type inference quits with an error message. --- --- @author Jonas Oberschweiber, Bjoern Peemoeller, Michael Hanus --- @version August 2016 --- @category meta ------------------------------------------------------------------------------ module FlatCurry.Annotated.TypeInference ( TypeEnv, getTypeEnv, getTypeEnvFromProgEnv , inferProg, inferProgFromProgEnv, inferProgEnv , inferFunction, inferFunctionEnv , inferNewFunctions, inferNewFunctionsEnv , inferExpr, inferExprEnv ) where import FiniteMap import List (find) import qualified Pretty as P import ErrorState import FlatCurry.Types import FlatCurry.Files import FlatCurry.Goodies (branchExpr, funcName) import FlatCurry.Annotated.Types import qualified FlatCurry.Annotated.Goodies as AFC (annExpr, funcName) import FlatCurry.Annotated.Pretty (ppQName, ppExp, ppTypeExp , ppVarIndex) import FlatCurry.Annotated.TypeSubst import SCC import Rewriting.Term import Rewriting.Unification import Unsafe -- --------------------------------------------------------------------------- -- Public Interface -- --------------------------------------------------------------------------- --- Infers the type of a whole program. --- --- @param p - the Prog to infer --- @return the inferred program or an error inferProg :: Prog -> IO (Either String (AProg TypeExpr)) inferProg p = getTypeEnv p >>= \te -> return (inferProgEnv te p) --- Infers the type of a whole program w.r.t. a list of imported modules. --- --- @param p - the Prog to infer --- @return the inferred program or an error inferProgFromProgEnv :: [(String, Prog)] -> Prog -> Either String (AProg TypeExpr) inferProgFromProgEnv env p = case getTypeEnvFromProgEnv env p of Left err -> Left err Right tyEnv -> inferProgEnv tyEnv p --- Infers the types of a single function specified by its qualified name. --- --- @param p - the Prog containing the function --- @param q - the qualified name of the function --- @return the inferred function or an error inferFunction :: Prog -> QName -> IO (Either String (AFuncDecl TypeExpr)) inferFunction p f = getTypeEnv p >>= \te -> return (inferFunctionEnv te p f) --- Infers the types of a group of (possibly mutually recursive) functions. --- Note that the functions are only monomorphically instantiated, i.e., --- polymorphic recursion is not supported. --- The given type may be too general, for instance a type variable only, --- and will be specialised to the inferred type. inferNewFunctions :: Prog -> [FuncDecl] -> IO (Either String [AFuncDecl TypeExpr]) inferNewFunctions p@(Prog mid _ _ _ _) fs = getTypeEnv p >>= \te -> return (inferNewFunctionsEnv te mid fs) --- Infer the type of a single expression. --- --- @param p - the Prog containing the function --- @param e - the expression --- @return the inferred expression or an error inferExpr :: Prog -> Expr -> IO (Either String (AExpr TypeExpr)) inferExpr p e = getTypeEnv p >>= \te -> return (inferExprEnv te e) -- --------------------------------------------------------------------------- --- Infers the type of a whole program. --- Uses the given type environment instead of generating a new one. --- --- @param te - the type environment --- @param p - the Prog to infer --- @return the inferred program or an error inferProgEnv :: TypeEnv -> Prog -> Either String (AProg TypeExpr) inferProgEnv te p = evalES (annProg p >+= inferAProg) (initTIM te) --- Infers the types of a single function specified by its qualified name. --- Uses the given type environment instead of generating a new one. --- --- @param te - the type environment --- @param p - the Prog containing the function --- @param fun - the qualified name of the function --- @return the inferred function or an error inferFunctionEnv :: TypeEnv -> Prog -> QName -> Either String (AFuncDecl TypeExpr) inferFunctionEnv te (Prog _ _ _ fs _) f = case find ((== f) . funcName) fs of Nothing -> Left $ P.pretty 80 $ P.text "No such function:" P.<+> ppQName f Just fd -> evalES (annFunc fd >+= inferFunc) (initTIM te) --- Infers the types of a group of (possibly mutually recursive) functions. --- Note that the functions are only monomorphically instantiated, i.e., --- polymorphic recursion is not supported. --- The given type may be too general, for instance a type variable only, --- and will be specialised to the inferred type. inferNewFunctionsEnv :: TypeEnv -> String -> [FuncDecl] -> Either String [AFuncDecl TypeExpr] inferNewFunctionsEnv te mid fs = evalES (infer (depGraph mid fs)) (initTIM te) where infer fss = concatMapES inferGroup fss >+= \fs' -> mapES (flip extract fs') fs inferGroup g = annFuncGroup g >+= inferFuncGroup >+= \afs -> extendTypeEnv [(f, ty) | AFunc f _ _ ty _ <- afs] >+ returnES afs extract f afs = case find ((== funcName f) . AFC.funcName) afs of Just af -> returnES af Nothing -> failES "Internal error: extract" --- Infers the types of a single expression. --- Uses the given type environment instead of generating a new one. --- --- @param te - the type environment --- @param e - the expression --- @return the inferred expression or an error inferExprEnv :: TypeEnv -> Expr -> Either String (AExpr TypeExpr) inferExprEnv te e = evalES (annExpr e >+= inferAExpr) (initTIM te) -- --------------------------------------------------------------------------- -- Computation of dependency graph and strongly connected components -- --------------------------------------------------------------------------- --- Compute the dependency graph of functions and separate it into strongly --- connected components. depGraph :: String -> [FuncDecl] -> [[FuncDecl]] depGraph mid = scc def use where def (Func f _ _ _ _) = [f] use (Func _ _ _ _ r) = case r of Rule _ e -> called e _ -> [] called (Var _) = [] called (Lit _) = [] called (Comb ct f@(m, _) es) | m == mid = (case ct of FuncCall -> [f] FuncPartCall _ -> [f] _ -> []) ++ concatMap called es | otherwise = concatMap called es called (Let bs e) = concatMap called (map snd bs ++ [e]) called (Free _ e) = called e called (Or a b) = concatMap called [a, b] called (Case _ e bs) = concatMap called (e : map branchExpr bs) called (Typed e _) = called e -- --------------------------------------------------------------------------- -- 1. Type environment -- --------------------------------------------------------------------------- --- A type environment. type TypeEnv = FM QName TypeExpr --- Looks up a type with a qualified name in a type environment. --- --- @param env - the type environment --- @param q - the qualified name to look for --- @return maybe the type lookupType :: TypeEnv -> QName -> Maybe TypeExpr lookupType = lookupFM --- Extract the type environment from the given Prog. --- --- @param p - the Prog --- @return a type environment getTypeEnv :: Prog -> IO TypeEnv getTypeEnv p = do is <- extractImported p return (extractKnownTypes $ p : is) --- Reads the interfaces of all modules imported into the given Prog. --- --- @param p - the Prog whose imports should be read --- @return the list of interface Progs extractImported :: Prog -> IO [Prog] extractImported (Prog _ is _ _ _) = mapIO readFlatCurryInt is --- Extract the type environment from the given Prog by lookup in a --- module name -> Prog environment. --- --- @param env - An environment mapping module names to Progs --- @param p - the Prog --- @return a type environment getTypeEnvFromProgEnv :: [(String, Prog)] -> Prog -> Either String TypeEnv getTypeEnvFromProgEnv env prog@(Prog _ imps _ _ _) = case extract imps of Left err -> Left err Right mods -> Right (extractKnownTypes $ prog : mods) where extract [] = Right [] extract (i:is) = case lookup i env of Nothing -> Left $ "getTypeEnvFromProgEnv: Could not find module " ++ i Just p -> case extract is of Left err -> Left err Right ps -> Right (p : ps) --- Extracts the type information of all function and datatype --- declarations from the given list of Progs. --- --- @param ps - the list of Progs --- @return a type environment extractKnownTypes :: [Prog] -> TypeEnv extractKnownTypes ps = listToFM (<) $ concatMap extractProg ps where extractProg :: Prog -> [(QName, TypeExpr)] extractProg (Prog _ _ td fd _) = concatMap extractTypeDecl td ++ map extractFuncDecl fd extractFuncDecl :: FuncDecl -> (QName, TypeExpr) extractFuncDecl (Func n _ _ ty _) = (n, ty) extractTypeDecl :: TypeDecl -> [(QName, TypeExpr)] extractTypeDecl (TypeSyn n _ _ ty) = [(n, ty)] extractTypeDecl (Type n _ vs cs) = map (extractConsDecl ty) cs where ty = TCons n (map TVar vs) extractConsDecl :: TypeExpr -> ConsDecl -> (QName, TypeExpr) extractConsDecl ty (Cons n _ _ tys) = (n, foldr FuncType ty tys) typeArity :: TypeExpr -> Int typeArity ty = case ty of FuncType _ b -> 1 + typeArity b _ -> 0 -- --------------------------------------------------------------------------- -- Type Inference Monad -- --------------------------------------------------------------------------- --- The monad contains an `Int` value for fresh type variable generation --- and a mapping from variable indices to their associated type --- variables. It returns a `String` if an error occured. type TIM a = ES String (TypeEnv, Int, TypeEnv, FM Int TypeExpr) a --- Initial TIM state. initTIM :: TypeEnv -> (TypeEnv, Int, TypeEnv, FM Int TypeExpr) initTIM te = (te, 0, emptyFM (<), emptyFM (<)) extendTypeEnv :: [(QName, TypeExpr)] -> TIM () extendTypeEnv ftys = gets >+= \ (te, v, fe, ve) -> puts (addListToFM te ftys, v, fe, ve) --- Retrieve the next fresh type variable. nextTVar :: TIM TypeExpr nextTVar = gets >+= \ (te, n, fun2Ty, var2Ty) -> puts (te, n + 1, fun2Ty, var2Ty) >+ returnES (TVar n) --- Intialize the mapping from variables to type variables. initVarTypes :: TIM () initVarTypes = modify $ \ (te, n, fe, _) -> (te, n, fe, emptyFM (<)) --- Intialize the type signature environment, i.e., delete all associations. initSigEnv :: TIM () initSigEnv = modify $ \ (te, n, _, ve) -> (te, n, emptyFM (<), ve) --- Insert a new variable/type variable association. insertVarType :: Int -> TypeExpr -> TIM () insertVarType v ty = modify $ \ (te, n, fe, var2Ty) -> (te, n, fe, addToFM var2Ty v ty) --- Insert a new function/type signature association. insertFunType :: QName -> TypeExpr -> TIM () insertFunType f sig = freshVariant sig >+= \ty -> modify $ \ (te, n, fe, ve) -> (te, n, addToFM fe f ty, ve) --- Look up the type variable associated to a variable. lookupVarType :: Int -> TIM (Maybe TypeExpr) lookupVarType v = gets >+= \ (_, _, _, var2Ty) -> returnES (lookupFM var2Ty v) --- Looks up a type in the type assumption or the type signature environment. --- Types found in the type assumption are instantiated to a fresh variant. --- --- @param q - the qualified name of the type to look up --- @return its type getTypeVariant :: QName -> TIM (QName, TypeExpr) getTypeVariant f = gets >+= \ (env, _, fe, _) -> case lookupType env f of Nothing -> case lookupFM fe f of Nothing -> failES $ "Internal error: getTypeVariant " ++ show f Just ty -> returnES (f, ty) Just t -> freshVariant t >+= \ty -> returnES (f, ty) --- Compute a fresh variant of a given type expression. --- --- @param ty - the type expression --- @return The renamed type expression freshVariant :: TypeExpr -> TIM TypeExpr freshVariant ty = snd <$> rename [] ty where rename ren (TVar i) = case lookup i ren of Just j -> returnES (ren, j) Nothing -> nextTVar >+= \j -> returnES ((i, j) : ren, j) rename ren (FuncType a b) = rename ren a >+= \ (ren1, a') -> rename ren1 b >+= \ (ren2, b') -> returnES (ren2, FuncType a' b') rename ren (TCons t tys) = mapAccumES rename ren tys >+= \(ren', tys') -> returnES (ren', TCons t tys') -- ----------------------------------------------------------------------------- -- 2. Annotation, traversing the AST and inserting fresh type variables -- ----------------------------------------------------------------------------- --- Converts the Prog to an AProg, inserting TVars into all expressions. --- --- @param prog - the prog to convert --- @return an AProg and the next TVar number in an TIM annProg :: Prog -> TIM (AProg TypeExpr) annProg (Prog mid is td fd od) = (\afd -> AProg mid is td afd od) <$> mapES annFunc fd annFuncGroup :: [FuncDecl] -> TIM [AFuncDecl TypeExpr] annFuncGroup fs = initSigEnv >+ mapES (uncurry insertFunType) ftys >+ mapES annFunc fs where ftys = [ (f, ty) | Func f _ _ ty _ <- fs] --- Converts the FuncDecl to an AFuncDecl, inserting TVars into all --- expressions. annFunc ::FuncDecl -> TIM (AFuncDecl TypeExpr) annFunc (Func qn a v _ r) = initVarTypes >+ AFunc qn a v <$> (snd <$> getTypeVariant qn) <*> annRule r --- Converts the Rule to an ARule, inserting TVars into all expressions. annRule :: Rule -> TIM (ARule TypeExpr) annRule (Rule vs e) = ARule <$> nextTVar <*> mapES annVar vs <*> annExpr e annRule (External s) = flip AExternal s <$> nextTVar --- Converts the Expr to an AExpr, inserting TVars into all sub-expressions. annExpr :: Expr -> TIM (AExpr TypeExpr) annExpr (Var i) = lookupVarType i >+= maybe (failES err) (\ty -> returnES (AVar ty i)) where err = P.pretty 80 $ P.text "Variable" P.<+> ppVarIndex i P.<+> P.text "was not initialized with a type" annExpr (Lit l) = nextTVar >+= \ty -> returnES (ALit ty l) annExpr (Comb t q es) = flip AComb t <$> nextTVar <*> getTypeVariant q <*> mapES annExpr es annExpr (Case t e bs) = flip ACase t <$> nextTVar <*> annExpr e <*> mapES annBranch bs annExpr (Or a b) = AOr <$> nextTVar <*> annExpr a <*> annExpr b annExpr (Let ds e) = ALet <$> nextTVar <*> annBindings ds <*> annExpr e where annBindings bs = let (vs, es) = unzip bs in mapES annBound vs >+= \vs' -> mapES annExpr es >+= \es' -> returnES (zip vs' es') annBound v = checkShadowing v >+ annVar v annExpr (Free vs e) = AFree <$> nextTVar <*> mapES annFree vs <*> annExpr e where annFree v = checkShadowing v >+ annVar v annExpr (Typed e ty) = ATyped <$> nextTVar <*> annExpr e <*> freshVariant ty --- Annotate a variable with a fresh type variable. annVar :: VarIndex -> TIM (VarIndex, TypeExpr) annVar v = nextTVar >+= \ty -> insertVarType v ty >+ returnES (v, ty) --- Checks whether a locally introduced variable is already defined in the --- surrounding scope, which indicates variable shadowing that is not allowed --- in FlatCurry files. This is our basic assumption in this type inferencer, --- and must therefore be met. Otherwise, the type inference must be extended. checkShadowing :: VarIndex -> TIM () checkShadowing v = lookupVarType v >+= maybe (returnES ()) (\_ -> failES err) where err = P.pretty 80 $ P.text "shadowing with variable" P.<+> ppVarIndex v --- Converts the BranchExpr to an ABranchExpr, inserting TVars --- into all expressions --- --- @param n - the first TVar number to use --- @return the ABranchExpr and the new next TVar number in an TIM annBranch :: BranchExpr -> TIM (ABranchExpr TypeExpr) annBranch (Branch p e) = ABranch <$> annPattern p <*> annExpr e --- Converts the Pattern into an APattern, inserting a TVar --- into the pattern --- --- @param n - the TVar number to use --- @return the APattern and the new next TVar number in an TIM annPattern :: Pattern -> TIM (APattern TypeExpr) annPattern (Pattern c vs) = APattern <$> nextTVar <*> getTypeVariant c <*> mapES annPVar vs where annPVar v = checkShadowing v >+ annVar v annPattern (LPattern l) = flip ALPattern l <$> nextTVar -- --------------------------------------------------------------------------- -- 3. Type inference -- --------------------------------------------------------------------------- --- Type equations type TypeEqs = [(TypeExpr, TypeExpr)] --- Smart constructor for type equation (=.=) :: TypeExpr -> TypeExpr -> (TypeExpr, TypeExpr) ty1 =.= ty2 = (ty1, ty2) ppTypeEqs :: TypeEqs -> P.Doc ppTypeEqs = P.vsep . map ppEquation where ppEquation (l, r) = ppTypeExp l P.<+> P.equals P.<+> ppTypeExp r --- Append two lists yielded by monadic computations. (++=) :: TIM [a] -> TIM [a] -> TIM [a] mxs ++= mys = (++) <$> mxs <*> mys --- Infers all types in the given program. --- --- @param p - the program to infer --- @param n - the next fresh TVar number --- @return the inferred program or an error inferAProg :: AProg TypeExpr -> TIM (AProg TypeExpr) inferAProg (AProg mid is td fd od) = (\fd' -> AProg mid is td fd' od) <$> mapES inferFunc fd --- Infers all types in the given function declaration group. inferFuncGroup :: [AFuncDecl TypeExpr] -> TIM [AFuncDecl TypeExpr] inferFuncGroup fs = -- returnES (unsafePerformIO (mapIO_ print fs)) >+= \() -> concatMapES (uncurry eqsRule) [(ty, r) | AFunc _ _ _ ty r <- fs] >+= \eqs -> -- returnES (unsafePerformIO (putStrLn (ppTypeEqs eqs))) >+= \() -> solve (P.text "functions" P.<+> doc) eqs >+= \ sigma -> -- returnES (unsafePerformIO (putStrLn (showAFCSubst sigma))) >+= \() -> mapES (normalize normFunc . substFunc sigma) fs >+= \afs -> -- returnES (unsafePerformIO (mapIO_ print afs)) >+= \() -> returnES afs where doc = P.hsep $ P.punctuate P.comma (map (ppQName . AFC.funcName) fs) --- Infers all types in the given function. --- --- @param n - the next fresh TVar number --- @param f - the function --- @return the inferred function or an error inferFunc :: AFuncDecl TypeExpr -> TIM (AFuncDecl TypeExpr) inferFunc func@(AFunc _ _ _ ty r) = eqsRule ty r >+= \ eqs -> solve (P.text "function" P.<+> ppQName (AFC.funcName func)) eqs >+= \ sigma -> normalize normFunc (substFunc sigma func) --- Infer the type of an expression. inferAExpr :: AExpr TypeExpr -> TIM (AExpr TypeExpr) inferAExpr e = eqsExpr e >+= \eqs -> solve (P.text "expression" P.<+> ppExp e) eqs >+= \sigma -> normalize normExpr (substExpr sigma e) --- Infer the type for a rule. eqsRule :: TypeExpr -> ARule TypeExpr -> TIM TypeEqs eqsRule ty (ARule ty2 vs e) = returnES [ty =.= ty2, ty2 =.= foldr1 FuncType (map snd vs ++ [exprType e])] ++= eqsExpr e eqsRule ty (AExternal ty2 _) = returnES [ty =.= ty2] --- Recursively generate equations for unification from an expression. --- --- @param e - the expression --- @return a list of type equations generated from `e`. eqsExpr :: AExpr TypeExpr -> TIM TypeEqs -- No equations to generate. eqsExpr (AVar _ _) = returnES [] -- The type of the expression is equal to the type of the literal. eqsExpr (ALit ty l) = returnES [ty =.= literalType l] -- Match the types of the argument expressions and the result type -- to the type of the function or constructor. eqsExpr (AComb ty _ (_, fty) es) = returnES [fty =.= foldr1 FuncType (map exprType es ++ [ty])] ++= concatMapES eqsExpr es -- Generate equations for the subject and the branches. eqsExpr (ACase ty _ e bs) = eqsExpr e ++= concatMapES (eqsBranch ty e) bs -- The type of the expression must be equal to the types -- of both argument expressions. eqsExpr (AOr ty a b) = returnES [exprType a =.= ty, exprType b =.= ty] ++= eqsExpr a ++= eqsExpr b -- The type of the expression must be equal to the type of the inner expression. -- The type of each bound variable must be equal to the type of the -- corresponding expression. eqsExpr (ALet ty bs e) = returnES [ty =.= exprType e] ++= returnES (map (\ ((_, vty), b) -> vty =.= exprType b) bs) ++= concatMapES eqsExpr (e : map snd bs) -- The type of the expression itself must be equal to the type -- of the inner expression. eqsExpr (AFree ty _ e) = returnES [ty =.= exprType e] ++= eqsExpr e -- The type of the expression must be equal to the type of the argument -- expression and to the specified type. eqsExpr (ATyped ty e tz) = returnES [ty =.= exprType e, ty =.= tz] ++= eqsExpr e --- Generate equations for a branch. --- --- - equating the type of the branch's expression to the type of the --- overall case expression --- - generating equations for the branch's pattern --- - generating equations for the branch's expression --- --- @param ty - the parent case expression's type --- @param subj - the case's subject expression --- @param b - the branch eqsBranch :: TypeExpr -> AExpr TypeExpr -> ABranchExpr TypeExpr -> TIM TypeEqs eqsBranch ty s (ABranch p be) = returnES [ty =.= exprType be] ++= eqsPattern (exprType s) p ++= eqsExpr be --- Generate equations for a pattern. --- --- - Equate the type of the case's subject to the type of the pattern. --- - For constructor patterns: Equate the type of the argument patterns and --- the type of the subject to the type of the constructor. --- - For literal patterns: Equate the type of the pattern to the type --- of the literal. eqsPattern :: TypeExpr -> APattern TypeExpr -> TIM TypeEqs eqsPattern ty (APattern pty (_, cty) vs) = returnES [ty =.= pty, cty =.= foldr1 FuncType (map snd vs ++ [pty])] eqsPattern ty (ALPattern pty l) = returnES [ty =.= pty, pty =.= literalType l] --- Extract the type of a Literal. literalType :: Literal -> TypeExpr literalType (Intc _) = TCons ("Prelude", "Int" ) [] literalType (Floatc _) = TCons ("Prelude", "Float") [] literalType (Charc _) = TCons ("Prelude", "Char" ) [] --- Extract the TypeExpr from an annotated Expr. exprType :: AExpr TypeExpr -> TypeExpr exprType = AFC.annExpr -- --------------------------------------------------------------------------- -- 4. Functions for interfacing with the Unification module -- --------------------------------------------------------------------------- --- Solve a list of type equations using unification. solve :: P.Doc -> TypeEqs -> TIM AFCSubst solve what eqs = case unify (fromTypeEqs eqs) of Left err -> failES $ P.pretty 80 $ ppUnificationError err P.<+> P.text "during type inference for:" P.<$$> P.nest 2 what Right sub -> returnES (mapFM (\_ -> toTypeExpr) sub) --- Converts a list of type expression equations into term equations. fromTypeEqs :: TypeEqs -> TermEqs String fromTypeEqs = map (\(a,b) -> (fromTypeExpr a, fromTypeExpr b)) --- Converts a list of term equations into type expression equations. toTypeEqs :: TermEqs String -> TypeEqs toTypeEqs = map (\(a,b) -> (toTypeExpr a =.= toTypeExpr b)) --- Converts the given type expression into a term for unification. fromTypeExpr :: TypeExpr -> Term String fromTypeExpr (TVar n) = TermVar n fromTypeExpr (TCons t vs) = TermCons (fromQName t) (map fromTypeExpr vs) fromTypeExpr (FuncType a b) = TermCons "->" [fromTypeExpr a, fromTypeExpr b] --- Converts the given unification term into a type expression toTypeExpr :: Term String -> TypeExpr toTypeExpr (TermVar n) = TVar n toTypeExpr (TermCons t vs) | t == "->" = FuncType (toTypeExpr (vs !! 0)) (toTypeExpr (vs !! 1)) | otherwise = TCons (toQName t) (map toTypeExpr vs) --- Converts a qualified name to a string. fromQName :: QName -> String fromQName (mod, typ) = mod ++ ";" ++ typ --- Converts a string to a qualified name. toQName :: String -> QName toQName str = (fst split, snd split) where split = splitFirst str ';' --- Splits a list at the first occurence of a given value. --- --- @param xs - the list to split --- @param x - the value to split at --- @return a tuple of the lists before and after the split splitFirst :: [a] -> a -> ([a], [a]) splitFirst [] _ = ([], []) splitFirst (x:xs) c | x == c = ([], xs) | otherwise = (x : fst rest, snd rest) where rest = splitFirst xs c --- Formats a unification error with the given message. ppUnificationError :: UnificationError String -> P.Doc ppUnificationError (Clash a b) = P.text "Clash:" P.<+> ppTypeExp (toTypeExpr a) P.<+> P.equals P.<+> ppTypeExp (toTypeExpr b) ppUnificationError (OccurCheck v t) = P.text "OccurCheck: Type variable" P.<+> ppTypeExp (toTypeExpr (TermVar v)) P.<+> P.text "occurs in type" P.<+> ppTypeExp (toTypeExpr t) -- --------------------------------------------------------------------------- -- 5. Functions for normalization of type variables. -- Renumbers type variables in a function starting from 0. -- --------------------------------------------------------------------------- -- We need to keep the next fresh variable number to assign and a mapping from -- existing variable numbers to newly assigned ones. -- Note that we do not need the error functionality but reuse the ES monad -- to avoid writing our own state monad. type NormState = (Int, FM Int Int) type Normalize a = a -> ES () NormState a --- Run a normalization operation. normalize :: Normalize a -> a -> ES String s a normalize norm x = case evalES (norm x) (0, emptyFM (<)) of Left _ -> failES $ "Normalization failed for: " ++ show x Right x' -> returnES x' --- Normalizes the type variable numbers in the given function. --- The parameters of the function are always the first types to be --- renumbered so they are assigned the lowest numbers. --- --- @param func - the function to normalize --- @return the normalized function normFunc :: Normalize (AFuncDecl TypeExpr) normFunc (AFunc f a v t r) = AFunc f a v <$> normType t <*> normRule r --- Recursively normalizes type variable numbers in the given type expression. --- --- @param type - the type expression to normalize --- @return the normalized type expression normType :: Normalize TypeExpr normType (TVar i) = gets >+= \(n, fm) -> case lookupFM fm i of Nothing -> puts (n + 1, addToFM fm i n) >+ returnES (TVar n) Just n' -> returnES (TVar n') normType (TCons q tys) = TCons q <$> mapES normType tys normType (FuncType a b) = FuncType <$> normType a <*> normType b --- Normalize a rule. normRule :: Normalize (ARule TypeExpr) normRule (ARule ty vs e) = ARule <$> normType ty <*> mapES normSnd vs <*> normExpr e normRule (AExternal ty s) = flip AExternal s <$> normType ty --- Normalizes type variable numbers in an expression. The next number --- to assign and a map from existing variable numbers to newly assigned --- ones are managed using the state monad. --- --- @param state - the current state --- @param expr - the expression to normalize --- @return the new state and normalized expression inside the state monad normExpr :: Normalize (AExpr TypeExpr) normExpr (AVar t v) = flip AVar v <$> normType t normExpr (ALit t l) = flip ALit l <$> normType t normExpr (AComb t ct f es) = flip AComb ct <$> normType t <*> normSnd f <*> mapES normExpr es normExpr (ALet t ds e) = ALet <$> normType t <*> mapES normBinding ds <*> normExpr e where normBinding (v, b) = (\x y -> (x,y)) <$> normSnd v <*> normExpr b normExpr (AOr t a b) = AOr <$> normType t <*> normExpr a <*> normExpr b normExpr (ACase t ct e bs) = flip ACase ct <$> normType t <*> normExpr e <*> mapES normBranch bs normExpr (AFree t vs e) = AFree <$> normType t <*> mapES normSnd vs <*> normExpr e normExpr (ATyped t e y) = ATyped <$> normType t <*> normExpr e <*> normType y normSnd :: Normalize (a, TypeExpr) normSnd (a, ty) = normType ty >+= \ty' -> returnES (a, ty') --- Normalizes type variable numbers in a branch. State is managed --- using the state monad, see normExpr for details. --- --- @param state - the current state --- @param branch - the branch to normalize --- @return the new state and normalized branch inside the state monad normBranch :: Normalize (ABranchExpr TypeExpr) normBranch (ABranch p e) = ABranch <$> normPattern p <*> normExpr e normPattern :: Normalize (APattern TypeExpr) normPattern (APattern t c vs) = APattern <$> normType t <*> normSnd c <*> mapES normSnd vs normPattern (ALPattern t l) = flip ALPattern l <$> normType t curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/FlatCurry/Annotated/TypeSubst.curry000066400000000000000000000110571305333611600301140ustar00rootroot00000000000000--- ---------------------------------------------------------------------------- --- Type substitutions on type-annotated AnnotatedFlatCurry --- --- @author Bjoern Peemoeller --- @version September 2014 --- @category meta --- ---------------------------------------------------------------------------- module FlatCurry.Annotated.TypeSubst where import FiniteMap import FlatCurry.Annotated.Types --- The (abstract) data type for substitutions on TypeExpr. type AFCSubst = FM TVarIndex TypeExpr showAFCSubst :: AFCSubst -> String showAFCSubst = unlines . map showOne . fmToList where showOne (k, v) = show k ++ " -> " ++ show v --- The empty substitution emptyAFCSubst :: AFCSubst emptyAFCSubst = emptyFM (<) --- Searches the substitution for a mapping from the given variable index --- to a term. --- --- @param subst - the substitution to search --- @param i - the index to search for --- @return the found type expression or Nothing lookupAFCSubst :: AFCSubst -> TVarIndex -> Maybe TypeExpr lookupAFCSubst = lookupFM -- ----------------------------------------------------------------------------- -- Functions for applying substitutions to expressions -- ----------------------------------------------------------------------------- --- Applies a substitution to a function. --- --- @param sub - the substitution --- @param f - the function --- @return the function with the substitution applied substFunc :: AFCSubst -> AFuncDecl TypeExpr -> AFuncDecl TypeExpr substFunc sub (AFunc f a v ty r) = AFunc f a v (subst sub ty) (substRule sub r) --- Applies a substitution to a type expression. --- --- @param sub - the substitution --- @param r - the rule --- @return the rule with the substitution applied substRule :: AFCSubst -> ARule TypeExpr -> ARule TypeExpr substRule sub (ARule ty vs e) = ARule (subst sub ty) (map (substSnd sub) vs) (substExpr sub e) substRule sub (AExternal ty s) = AExternal (subst sub ty) s --- Applies a substitution to a type expression. --- --- @param sub - the substitution --- @param ex - the expression --- @return the expression with the substitution applied substExpr :: AFCSubst -> AExpr TypeExpr -> AExpr TypeExpr substExpr sub (AComb ty t f ps) = AComb (subst sub ty) t (substSnd sub f) (map (substExpr sub) ps) substExpr sub (AVar ty k) = AVar (subst sub ty) k substExpr sub (ACase ty t e bs) = ACase (subst sub ty) t (substExpr sub e) (map (substBranch sub) bs) substExpr sub (ALit ty l) = ALit (subst sub ty) l substExpr sub (AOr ty a b) = AOr (subst sub ty) (substExpr sub a) (substExpr sub b) substExpr sub (ALet ty bs e) = ALet (subst sub ty) (map substBinding bs) (substExpr sub e) where substBinding (v, b) = (substSnd sub v, substExpr sub b) substExpr sub (AFree ty vs e) = AFree (subst sub ty) (map (substSnd sub) vs) (substExpr sub e) substExpr sub (ATyped ty e ty') = ATyped (subst sub ty) (substExpr sub e) (subst sub ty') substSnd :: AFCSubst -> (a, TypeExpr) -> (a, TypeExpr) substSnd sub (a, ty) = (a, subst sub ty) --- Applies a substitution to a branch expression. --- --- @param sub - the substitution --- @param b - the branch --- @return the branch with the substitution applied substBranch :: AFCSubst -> ABranchExpr TypeExpr -> ABranchExpr TypeExpr substBranch sub (ABranch p e) = ABranch (substPattern sub p) (substExpr sub e) --- Applies a substitution to a pattern. --- --- @param sub - the substitution --- @param p - the pattern --- @return the pattern with the substitution applied substPattern :: AFCSubst -> APattern TypeExpr -> APattern TypeExpr substPattern sub (APattern t f vs) = APattern (subst sub t) (substSnd sub f) (map (substSnd sub) vs) substPattern sub (ALPattern t l) = ALPattern (subst sub t) l --- Looks up a type in a substitution and converts the resulting Term --- to a TypeExpr. Returns a given default value if the lookup fails. --- --- @param t - the type to look up --- @param e - the default value --- @param sub - the substitution to search in --- @return either the looked-up and converted type or the default type subst :: AFCSubst -> TypeExpr -> TypeExpr subst sub e@(TVar n) = maybe e id (lookupAFCSubst sub n) subst sub (TCons t tys) = TCons t (map (subst sub) tys) subst sub (FuncType a b) = FuncType (subst sub a) (subst sub b) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/FlatCurry/Annotated/Types.curry000066400000000000000000000040021305333611600272460ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library contains a version of FlatCurry's abstract syntax tree which --- can be annotated with arbitrary information due to a polymorphic type --- parameter. --- For instance, this could be used to annotate function declarations --- and expressions with their corresponding type. --- --- For more information about the abstract syntax tree of `FlatCurry`, --- see the documentation of the respective module. --- --- @author Jonas Oberschweiber, Bjoern Peemoeller, Michael Hanus --- @version October 2015 --- @category meta ------------------------------------------------------------------------------ module FlatCurry.Annotated.Types ( module FlatCurry.Annotated.Types , module FlatCurry.Types ) where import FlatCurry.Types ( QName, VarIndex, Visibility (..), TVarIndex , TypeDecl (..), OpDecl (..), Fixity (..) , TypeExpr (..), ConsDecl (..) , Literal (..), CombType (..), CaseType (..) ) --- Annotated FlatCurry program (corresponds to a module) data AProg a = AProg String [String] [TypeDecl] [AFuncDecl a] [OpDecl] --- Arity of a function declaration type Arity = Int --- Annotated function declaration data AFuncDecl a = AFunc QName Arity Visibility TypeExpr (ARule a) --- Annotated function rule data ARule a = ARule a [(VarIndex, a)] (AExpr a) | AExternal a String --- Annotated expression data AExpr a = AVar a VarIndex | ALit a Literal | AComb a CombType (QName, a) [AExpr a] | ALet a [((VarIndex, a), AExpr a)] (AExpr a) | AFree a [(VarIndex, a)] (AExpr a) | AOr a (AExpr a) (AExpr a) | ACase a CaseType (AExpr a) [ABranchExpr a] | ATyped a (AExpr a) TypeExpr --- Annotated case branch data ABranchExpr a = ABranch (APattern a) (AExpr a) --- Annotated pattern data APattern a = APattern a (QName, a) [(VarIndex, a)] --- constructor pattern | ALPattern a Literal --- literal pattern curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/FlatCurry/Compact.curry000066400000000000000000000557451305333611600256370ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This module contains functions to reduce the size of FlatCurry programs --- by combining the main module and all imports into a single program --- that contains only the functions directly or indirectly called from --- a set of main functions. --- --- @author Michael Hanus, Carsten Heine --- @version August 2016 --- @category meta ------------------------------------------------------------------------------ {-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-} module FlatCurry.Compact(generateCompactFlatCurryFile,computeCompactFlatCurry, Option(..),RequiredSpec,requires,alwaysRequired, defaultRequired) where import FlatCurry.Types import FlatCurry.Files import SetRBT import TableRBT import Maybe import List (nub, union) import FileGoodies import FilePath (takeFileName, ()) import Directory import Sort (cmpString, leqString) import XML import Distribution (lookupModuleSourceInLoadPath, stripCurrySuffix) infix 0 `requires` ------------------------------------------------------------------------------ --- Options to guide the compactification process. --- @cons Verbose - for more output --- @cons Main - optimize for one main (unqualified!) function supplied here --- @cons Exports - optimize w.r.t. the exported functions of the module only --- @cons InitFuncs - optimize w.r.t. given list of initially required functions --- @cons Required - list of functions that are implicitly required and, thus, --- should not be deleted if the corresponding module --- is imported --- @cons Import - module that should always be imported --- (useful in combination with option InitFuncs) data Option = Verbose | Main String | Exports | InitFuncs [QName] | Required [RequiredSpec] | Import String isMainOption :: Option -> Bool isMainOption o = case o of Main _ -> True _ -> False getMainFuncFromOptions :: [Option] -> String getMainFuncFromOptions (o:os) = case o of Main f -> f _ -> getMainFuncFromOptions os getRequiredFromOptions :: [Option] -> [RequiredSpec] getRequiredFromOptions options = concat [ fs | Required fs <- options ] -- add Import for modules containing always required functions: addImport2Options :: [Option] -> [Option] addImport2Options options = options ++ map Import (nub (concatMap alwaysReqMod (getRequiredFromOptions options))) where alwaysReqMod (AlwaysReq (m,_)) = [m] alwaysReqMod (Requires _ _) = [] ------------------------------------------------------------------------------ --- Data type to specify requirements of functions. data RequiredSpec = AlwaysReq QName | Requires QName QName --- (fun `requires` reqfun) specifies that the use of the function "fun" --- implies the application of function "reqfun". requires :: QName -> QName -> RequiredSpec requires fun reqfun = Requires fun reqfun --- (alwaysRequired fun) specifies that the function "fun" should be --- always present if the corresponding module is loaded. alwaysRequired :: QName -> RequiredSpec alwaysRequired fun = AlwaysReq fun --- Functions that are implicitly required in a FlatCurry program --- (since they might be generated by external functions like --- "==" or "=:=" on the fly). defaultRequired :: [RequiredSpec] defaultRequired = [alwaysRequired (prelude,"apply"), alwaysRequired (prelude,"letrec"), alwaysRequired (prelude,"cond"), alwaysRequired (prelude,"failure"), (prelude,"==") `requires` (prelude,"&&"), (prelude,"=:=") `requires` (prelude,"&"), (prelude,"=:<=") `requires` (prelude,"ifVar"), (prelude,"=:<=") `requires` (prelude,"=:="), (prelude,"=:<=") `requires` (prelude,"&>"), (prelude,"=:<<=") `requires` (prelude,"&"), (prelude,"$#") `requires` (prelude,"ensureNotFree"), (prelude,"readFile") `requires` (prelude,"prim_readFileContents"), ("Ports","prim_openPortOnSocket") `requires` ("Ports","basicServerLoop"), ("Ports","prim_timeoutOnStream") `requires` ("Ports","basicServerLoop"), ("Ports","prim_choiceSPEP") `requires` ("Ports","basicServerLoop"), ("Dynamic","getDynamicKnowledge") `requires` ("Dynamic","isKnownAtTime") ] prelude :: String prelude = "Prelude" --- Get functions that are required in a module w.r.t. --- a requirement specification. getRequiredInModule :: [RequiredSpec] -> String -> [QName] getRequiredInModule reqspecs mod = concatMap getImpReq reqspecs where getImpReq (AlwaysReq (mf,f)) = if mf==mod then [(mf,f)] else [] getImpReq (Requires _ _) = [] --- Get functions that are implicitly required by a function w.r.t. --- a requirement specification. getImplicitlyRequired :: [RequiredSpec] -> QName -> [QName] getImplicitlyRequired reqspecs fun = concatMap getImpReq reqspecs where getImpReq (AlwaysReq _) = [] getImpReq (Requires f reqf) = if f==fun then [reqf] else [] --- The basic types that are always required in a FlatCurry program. defaultRequiredTypes :: [QName] defaultRequiredTypes = [(prelude,"()"),(prelude,"Int"),(prelude,"Float"),(prelude,"Char"), (prelude,"Success"),(prelude,"IO")] ------------------------------------------------------------------------------- -- Main functions: ------------------------------------------------------------------------------- --- Computes a single FlatCurry program containing all functions potentially --- called from a set of main functions and writes it into a FlatCurry file. --- This is done by merging all imported FlatCurry modules and removing --- the imported functions that are definitely not used. --- @param options - list of options --- @param progname - name of the Curry program that should be compacted --- @param target - name of the target file where the compact program is saved generateCompactFlatCurryFile :: [Option] -> String -> String -> IO () generateCompactFlatCurryFile options progname target = do optprog <- computeCompactFlatCurry options progname writeFCY target optprog done --- Computes a single FlatCurry program containing all functions potentially --- called from a set of main functions. --- This is done by merging all imported FlatCurry modules (these are loaded --- demand-driven so that modules that contains no potentially called functions --- are not loaded) and removing the imported functions that are definitely --- not used. --- @param options - list of options --- @param progname - name of the Curry program that should be compacted --- @return the compact FlatCurry program computeCompactFlatCurry :: [Option] -> String -> IO Prog computeCompactFlatCurry orgoptions progname = let options = addImport2Options orgoptions in if (elem Exports options) && (any isMainOption options) then error "CompactFlat: Options 'Main' and 'Exports' can't be be used together!" else do putStr "CompactFlat: Searching relevant functions in module " prog <- readCurrentFlatCurry progname resultprog <- makeCompactFlatCurry prog options putStrLn ("CompactFlat: Number of functions after optimization: " ++ show (length (moduleFuns resultprog))) return resultprog --- Create the optimized program. makeCompactFlatCurry :: Prog -> [Option] -> IO Prog makeCompactFlatCurry mainmod options = do (initfuncs,loadedmnames,loadedmods) <- requiredInCompactProg mainmod options let initFuncTable = extendFuncTable (emptyTableRBT leqQName) (concatMap moduleFuns loadedmods) required = getRequiredFromOptions options loadedreqfuns = concatMap (getRequiredInModule required) (map moduleName loadedmods) initreqfuncs = initfuncs ++ loadedreqfuns (finalmods,finalfuncs,finalcons,finaltcons) <- getCalledFuncs required loadedmnames loadedmods initFuncTable (foldr insertRBT (emptySetRBT leqQName) initreqfuncs) (emptySetRBT leqQName) (emptySetRBT leqQName) initreqfuncs putStrLn ("\nCompactFlat: Total number of functions (without unused imports): " ++ show (foldr (+) 0 (map (length . moduleFuns) finalmods))) let finalfnames = map functionName finalfuncs return (Prog (moduleName mainmod) [] (let allTDecls = concatMap moduleTypes finalmods reqTCons = extendTConsWithConsType finalcons finaltcons allTDecls allReqTCons = requiredDatatypes reqTCons allTDecls in filter (\tdecl->tconsName tdecl `elemRBT` allReqTCons) allTDecls) finalfuncs (filter (\ (Op oname _ _) -> oname `elem` finalfnames) (concatMap moduleOps finalmods))) -- compute the transitive closure of a set of type constructors w.r.t. -- to a given list of type declaration so that the set contains -- all type constructor names occurring in the type declarations: requiredDatatypes :: SetRBT QName -> [TypeDecl] -> SetRBT QName requiredDatatypes tcnames tdecls = let newtcons = concatMap (newTypeConsOfTDecl tcnames) tdecls in if null newtcons then tcnames else requiredDatatypes (foldr insertRBT tcnames newtcons) tdecls -- Extract the new type constructors (w.r.t. a given set) contained in a -- type declaration: newTypeConsOfTDecl :: SetRBT QName -> TypeDecl -> [QName] newTypeConsOfTDecl tcnames (TypeSyn tcons _ _ texp) = if tcons `elemRBT` tcnames then filter (\tc -> not (tc `elemRBT` tcnames)) (allTypesOfTExpr texp) else [] newTypeConsOfTDecl tcnames (Type tcons _ _ cdecls) = if tcons `elemRBT` tcnames then filter (\tc -> not (tc `elemRBT` tcnames)) (concatMap (\ (Cons _ _ _ texps) -> concatMap allTypesOfTExpr texps) cdecls) else [] -- Extend set of type constructor with type constructors of data declarations -- contain some constructor. extendTConsWithConsType :: SetRBT QName -> SetRBT QName -> [TypeDecl] -> SetRBT QName extendTConsWithConsType _ tcons [] = tcons extendTConsWithConsType cnames tcons (TypeSyn tname _ _ _ : tds) = extendTConsWithConsType cnames (insertRBT tname tcons) tds extendTConsWithConsType cnames tcons (Type tname _ _ cdecls : tds) = if tname `elem` defaultRequiredTypes || any (\cdecl->consName cdecl `elemRBT` cnames) cdecls then extendTConsWithConsType cnames (insertRBT tname tcons) tds else extendTConsWithConsType cnames tcons tds -- Extend function table (mapping from qualified names to function declarations) -- by some new function declarations: extendFuncTable :: TableRBT QName FuncDecl -> [FuncDecl] -> TableRBT QName FuncDecl extendFuncTable ftable fdecls = foldr (\f t -> updateRBT (functionName f) f t) ftable fdecls ------------------------------------------------------------------------------- -- Generate the Prog to start with: ------------------------------------------------------------------------------- -- Compute the initially required functions in the compact program -- together with the set of module names and contents that are initially loaded: requiredInCompactProg :: Prog -> [Option] -> IO ([QName],SetRBT String,[Prog]) requiredInCompactProg mainmod options | not (null initfuncs) = do impprogs <- mapIO readCurrentFlatCurry imports return (concat initfuncs, add2mainmodset imports, mainmod:impprogs) | Exports `elem` options = do impprogs <- mapIO readCurrentFlatCurry imports return (nub mainexports, add2mainmodset imports, mainmod:impprogs) | any isMainOption options = let func = getMainFuncFromOptions options in if (mainmodname,func) `elem` (map functionName (moduleFuns mainmod)) then do impprogs <- mapIO readCurrentFlatCurry imports return ([(mainmodname,func)], add2mainmodset imports, mainmod:impprogs) else error $ "CompactFlat: Cannot find main function \""++func++"\"!" | otherwise = do impprogs <- mapIO readCurrentFlatCurry (nub (imports ++ moduleImports mainmod)) return (nub (mainexports ++ concatMap (exportedFuncNames . moduleFuns) impprogs), add2mainmodset (map moduleName impprogs), mainmod:impprogs) where imports = nub [ mname | Import mname <- options ] mainmodname = moduleName mainmod initfuncs = [ fs | InitFuncs fs <- options ] mainexports = exportedFuncNames (moduleFuns mainmod) mainmodset = insertRBT mainmodname (emptySetRBT leqString) add2mainmodset mnames = foldr insertRBT mainmodset mnames -- extract the names of all exported functions: exportedFuncNames :: [FuncDecl] -> [QName] exportedFuncNames funs = map (\(Func name _ _ _ _)->name) (filter (\(Func _ _ vis _ _)->vis==Public) funs) ------------------------------------------------------------------------------- --- Adds all required functions to the program and load modules, if necessary. --- @param required - list of potentially required functions --- @param loadedmnames - set of already considered module names --- @param progs - list of already loaded modules --- @param functable - mapping from (loaded) function names to their definitions --- @param loadedfnames - set of already loaded function names --- @param loadedcnames - set of already required data constructors --- @param loadedtnames - set of already required data constructors --- @param fnames - list of function names to be analyzed for dependencies --- @return (list of loaded modules, list of required function declarations, --- set of required data constructors, set of required type names) getCalledFuncs :: [RequiredSpec] -> SetRBT String -> [Prog] -> TableRBT QName FuncDecl -> SetRBT QName -> SetRBT QName -> SetRBT QName -> [QName] -> IO ([Prog],[FuncDecl],SetRBT QName,SetRBT QName) getCalledFuncs _ _ progs _ _ dcs ts [] = return (progs,[],dcs,ts) getCalledFuncs required loadedmnames progs functable loadedfnames loadedcnames loadedtnames ((m,f):fs) | not (elemRBT m loadedmnames) = do newmod <- readCurrentFlatCurry m let reqnewfun = getRequiredInModule required m getCalledFuncs required (insertRBT m loadedmnames) (newmod:progs) (extendFuncTable functable (moduleFuns newmod)) (foldr insertRBT loadedfnames reqnewfun) loadedcnames loadedtnames ((m,f):fs ++ reqnewfun) | lookupRBT (m,f) functable == Nothing = -- this must be a data constructor: ingore it since already considered getCalledFuncs required loadedmnames progs functable loadedfnames loadedcnames loadedtnames fs | otherwise = do let fdecl = fromJust (lookupRBT (m,f) functable) funcCalls = allFuncCalls fdecl newFuncCalls = filter (\qn->not (elemRBT qn loadedfnames)) funcCalls newReqs = concatMap (getImplicitlyRequired required) newFuncCalls consCalls = allConstructorsOfFunc fdecl newConsCalls = filter (\qn->not (elemRBT qn loadedcnames)) consCalls newtcons = allTypesOfFunc fdecl (newprogs,newfuns,newcons, newtypes) <- getCalledFuncs required loadedmnames progs functable (foldr insertRBT loadedfnames (newFuncCalls++newReqs)) (foldr insertRBT loadedcnames consCalls) (foldr insertRBT loadedtnames newtcons) (fs ++ newFuncCalls ++ newReqs ++ newConsCalls) return (newprogs, fdecl:newfuns, newcons, newtypes) ------------------------------------------------------------------------------- -- Operations to get all function calls, types,... in a function declaration: ------------------------------------------------------------------------------- --- Get all function calls in a function declaration and remove duplicates. --- @param funcDecl - a function declaration in FlatCurry --- @return a list of all function calls allFuncCalls :: FuncDecl -> [QName] allFuncCalls (Func _ _ _ _ (External _)) = [] allFuncCalls (Func _ _ _ _ (Rule _ expr)) = nub (allFuncCallsOfExpr expr) --- Get all function calls in an expression. --- @param expr - an expression --- @return a list of all function calls allFuncCallsOfExpr :: Expr -> [QName] allFuncCallsOfExpr (Var _) = [] allFuncCallsOfExpr (Lit _) = [] allFuncCallsOfExpr (Comb ctype fname exprs) = case ctype of FuncCall -> fname:fnames FuncPartCall _ -> fname:fnames _ -> fnames where fnames = concatMap allFuncCallsOfExpr exprs allFuncCallsOfExpr (Free _ expr) = allFuncCallsOfExpr expr allFuncCallsOfExpr (Let bs expr) = concatMap (allFuncCallsOfExpr . snd) bs ++ allFuncCallsOfExpr expr allFuncCallsOfExpr (Or expr1 expr2) = allFuncCallsOfExpr expr1 ++ allFuncCallsOfExpr expr2 allFuncCallsOfExpr (Case _ expr branchExprs) = allFuncCallsOfExpr expr ++ concatMap allFuncCallsOfBranchExpr branchExprs allFuncCallsOfExpr (Typed expr _) = allFuncCallsOfExpr expr --- Get all function calls in a branch expression in case expressions. --- @param branchExpr - a branch expression --- @return a list of all function calls allFuncCallsOfBranchExpr :: BranchExpr -> [QName] allFuncCallsOfBranchExpr (Branch _ expr) = allFuncCallsOfExpr expr --- Get all data constructors in a function declaration. allConstructorsOfFunc :: FuncDecl -> [QName] allConstructorsOfFunc (Func _ _ _ _ (External _)) = [] allConstructorsOfFunc (Func _ _ _ _ (Rule _ expr)) = allConsOfExpr expr --- Get all data constructors in an expression. allConsOfExpr :: Expr -> [QName] allConsOfExpr (Var _) = [] allConsOfExpr (Lit _) = [] allConsOfExpr (Comb ctype cname exprs) = case ctype of ConsCall -> cname:cnames ConsPartCall _ -> cname:cnames _ -> cnames where cnames = unionMap allConsOfExpr exprs allConsOfExpr (Free _ expr) = allConsOfExpr expr allConsOfExpr (Let bs expr) = union (unionMap (allConsOfExpr . snd) bs) (allConsOfExpr expr) allConsOfExpr (Or expr1 expr2) = union (allConsOfExpr expr1) (allConsOfExpr expr2) allConsOfExpr (Case _ expr branchExprs) = union (allConsOfExpr expr) (unionMap consOfBranch branchExprs) where consOfBranch (Branch (LPattern _) e) = allConsOfExpr e consOfBranch (Branch (Pattern c _) e) = union [c] (allConsOfExpr e) allConsOfExpr (Typed expr _) = allConsOfExpr expr --- Get all type constructors in a function declaration. allTypesOfFunc :: FuncDecl -> [QName] allTypesOfFunc (Func _ _ _ texp _) = allTypesOfTExpr texp --- Get all data constructors in an expression. allTypesOfTExpr :: TypeExpr -> [QName] allTypesOfTExpr (TVar _) = [] allTypesOfTExpr (FuncType texp1 texp2) = union (allTypesOfTExpr texp1) (allTypesOfTExpr texp2) allTypesOfTExpr (TCons tcons args) = union [tcons] (unionMap allTypesOfTExpr args) unionMap :: (a -> [b]) -> [a] -> [b] unionMap f = foldr union [] . map f ------------------------------------------------------------------------------- -- Functions to get direct access to some data inside a datatype: ------------------------------------------------------------------------------- --- Extracts the function name of a function declaration. functionName :: FuncDecl -> QName functionName (Func name _ _ _ _) = name --- Extracts the constructor name of a constructor declaration. consName :: ConsDecl -> QName consName (Cons name _ _ _) = name --- Extracts the type name of a type declaration. tconsName :: TypeDecl -> QName tconsName (Type name _ _ _) = name tconsName (TypeSyn name _ _ _) = name --- Extracts the names of imported modules of a FlatCurry program. moduleImports :: Prog -> [String] moduleImports (Prog _ imports _ _ _) = imports --- Extracts the types of a FlatCurry program. moduleTypes :: Prog -> [TypeDecl] moduleTypes (Prog _ _ types _ _) = types --- Extracts the operators of a FlatCurry program. moduleOps :: Prog -> [OpDecl] moduleOps (Prog _ _ _ _ ops) = ops --- Extracts the name of the Prog. moduleName :: Prog -> String moduleName (Prog name _ _ _ _) = name --- Extracts the functions of the program. moduleFuns :: Prog -> [FuncDecl] moduleFuns (Prog _ _ _ funs _) = funs ------------------------------------------------------------------------------- -- Functions for comparison: ------------------------------------------------------------------------------- --- Compares two qualified names. --- Returns True, if the first name is lexicographically smaller than --- the second name using the leString function to compare String. leqQName :: QName -> QName -> Bool leqQName (m1,n1) (m2,n2) = let cm = cmpString m1 m2 in cm==LT || (cm==EQ && leqString n1 n2) ------------------------------------------------------------------------------- -- I/O functions: ------------------------------------------------------------------------------- -- Read a FlatCurry program (parse only if necessary): readCurrentFlatCurry :: String -> IO Prog readCurrentFlatCurry modname = do putStr (modname++"...") mbsrc <- lookupModuleSourceInLoadPath modname case mbsrc of Nothing -> error ("Curry file for module \""++modname++"\" not found!") Just (moddir,progname) -> do let fcyname = flatCurryFileName (moddir takeFileName modname) fcyexists <- doesFileExist fcyname if not fcyexists then readFlatCurry modname >>= processPrimitives progname else do ctime <- getModificationTime progname ftime <- getModificationTime fcyname if ctime>ftime then readFlatCurry progname >>= processPrimitives progname else readFlatCurryFile fcyname >>= processPrimitives progname -- read primitive specification and transform FlatCurry program accordingly: processPrimitives :: String -> Prog -> IO Prog processPrimitives progname prog = do pspecs <- readPrimSpec (moduleName prog) (stripCurrySuffix progname ++ ".prim_c2p") return (mergePrimSpecIntoModule pspecs prog) mergePrimSpecIntoModule :: [(QName,QName)] -> Prog -> Prog mergePrimSpecIntoModule trans (Prog name imps types funcs ops) = Prog name imps types (concatMap (mergePrimSpecIntoFunc trans) funcs) ops mergePrimSpecIntoFunc :: [(QName,QName)] -> FuncDecl -> [FuncDecl] mergePrimSpecIntoFunc trans (Func name ar vis tp rule) = let fname = lookup name trans in if fname==Nothing then [Func name ar vis tp rule] else let Just (lib,entry) = fname in if null entry then [] else [Func name ar vis tp (External (lib++' ':entry))] readPrimSpec :: String -> String -> IO [(QName,QName)] readPrimSpec mod xmlfilename = do existsXml <- doesFileExist xmlfilename if existsXml then do --putStrLn $ "Reading specification '"++xmlfilename++"'..." xmldoc <- readXmlFile xmlfilename return (xml2primtrans mod xmldoc) else return [] xml2primtrans :: String -> XmlExp -> [(QName,QName)] xml2primtrans mod (XElem "primitives" [] primitives) = map xml2prim primitives where xml2prim (XElem "primitive" (("name",fname):_) [XElem "library" [] xlib, XElem "entry" [] xfun]) = ((mod,fname),(textOfXml xlib,textOfXml xfun)) xml2prim (XElem "ignore" (("name",fname):_) []) = ((mod,fname),("","")) ------------------------------------------------------------------------------- curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/FlatCurry/Files.curry000066400000000000000000000141261305333611600252770ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library supports meta-programming, i.e., the manipulation of --- Curry programs in Curry. This library defines I/O actions --. to read Curry programs and transform them into this representation. --- --- @author Michael Hanus --- @version October 2015 --- @category meta ------------------------------------------------------------------------------ module FlatCurry.Files where import Directory (doesFileExist) import Distribution ( FrontendParams, FrontendTarget (..), defaultParams , setQuiet, inCurrySubdir, stripCurrySuffix , callFrontend, callFrontendWithParams , lookupModuleSourceInLoadPath, getLoadPathForModule ) import FileGoodies (getFileInPath, lookupFileInPath) import FilePath (takeFileName, (), (<.>)) import FlatCurry.Types import Maybe (isNothing) import ReadShowTerm (readUnqualifiedTerm, showTerm) --- I/O action which parses a Curry program and returns the corresponding --- FlatCurry program. --- Thus, the argument is the module path (without suffix ".curry" --- or ".lcurry") and the result is a FlatCurry term representing this --- program. readFlatCurry :: String -> IO Prog readFlatCurry progname = readFlatCurryWithParseOptions progname (setQuiet True defaultParams) --- I/O action which parses a Curry program --- with respect to some parser options and returns the --- corresponding FlatCurry program. --- This I/O action is used by the standard action `readFlatCurry`. --- @param progfile - the program file name (without suffix ".curry") --- @param options - parameters passed to the front end readFlatCurryWithParseOptions :: String -> FrontendParams -> IO Prog readFlatCurryWithParseOptions progname options = do mbsrc <- lookupModuleSourceInLoadPath progname case mbsrc of Nothing -> do -- no source file, try to find FlatCurry file in load path: loadpath <- getLoadPathForModule progname filename <- getFileInPath (flatCurryFileName (takeFileName progname)) [""] loadpath readFlatCurryFile filename Just (dir,_) -> do callFrontendWithParams FCY options progname readFlatCurryFile (flatCurryFileName (dir takeFileName progname)) --- Transforms a name of a Curry program (with or without suffix ".curry" --- or ".lcurry") into the name of the file containing the --- corresponding FlatCurry program. flatCurryFileName :: String -> String flatCurryFileName prog = inCurrySubdir (stripCurrySuffix prog) <.> "fcy" --- Transforms a name of a Curry program (with or without suffix ".curry" --- or ".lcurry") into the name of the file containing the --- corresponding FlatCurry program. flatCurryIntName :: String -> String flatCurryIntName prog = inCurrySubdir (stripCurrySuffix prog) <.> "fint" --- I/O action which reads a FlatCurry program from a file in ".fcy" format. --- In contrast to `readFlatCurry`, this action does not parse --- a source program. Thus, the argument must be the name of an existing --- file (with suffix ".fcy") containing a FlatCurry program in ".fcy" --- format and the result is a FlatCurry term representing this program. readFlatCurryFile :: String -> IO Prog readFlatCurryFile filename = do exfcy <- doesFileExist filename if exfcy then readExistingFCY filename else do let subdirfilename = inCurrySubdir filename exdirfcy <- doesFileExist subdirfilename if exdirfcy then readExistingFCY subdirfilename else error ("EXISTENCE ERROR: FlatCurry file '" ++ filename ++ "' does not exist") where readExistingFCY fname = do filecontents <- readFile fname return (readUnqualifiedTerm ["FlatCurry.Types","Prelude"] filecontents) --- I/O action which returns the interface of a Curry module, i.e., --- a FlatCurry program containing only "Public" entities and function --- definitions without rules (i.e., external functions). --- The argument is the file name without suffix ".curry" --- (or ".lcurry") and the result is a FlatCurry term representing the --- interface of this module. readFlatCurryInt :: String -> IO Prog readFlatCurryInt progname = do readFlatCurryIntWithParseOptions progname (setQuiet True defaultParams) --- I/O action which parses Curry program --- with respect to some parser options and returns the FlatCurry --- interface of this program, i.e., --- a FlatCurry program containing only "Public" entities and function --- definitions without rules (i.e., external functions). --- The argument is the file name without suffix ".curry" --- (or ".lcurry") and the result is a FlatCurry term representing the --- interface of this module. readFlatCurryIntWithParseOptions :: String -> FrontendParams -> IO Prog readFlatCurryIntWithParseOptions progname options = do mbsrc <- lookupModuleSourceInLoadPath progname case mbsrc of Nothing -> do -- no source file, try to find FlatCurry file in load path: loadpath <- getLoadPathForModule progname filename <- getFileInPath (flatCurryIntName (takeFileName progname)) [""] loadpath readFlatCurryFile filename Just (dir,_) -> do callFrontendWithParams FINT options progname readFlatCurryFile (flatCurryIntName (dir takeFileName progname)) --- Writes a FlatCurry program into a file in ".fcy" format. --- The first argument must be the name of the target file --- (with suffix ".fcy"). writeFCY :: String -> Prog -> IO () writeFCY file prog = writeFile file (showTerm prog) --- Returns the name of the FlatCurry file of a module in the load path, --- if this file exists. lookupFlatCurryFileInLoadPath :: String -> IO (Maybe String) lookupFlatCurryFileInLoadPath modname = getLoadPathForModule modname >>= lookupFileInPath (flatCurryFileName modname) [""] --- Returns the name of the FlatCurry file of a module in the load path, --- if this file exists. getFlatCurryFileInLoadPath :: String -> IO String getFlatCurryFileInLoadPath modname = getLoadPathForModule modname >>= getFileInPath (flatCurryFileName modname) [""] curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/FlatCurry/FlexRigid.curry000066400000000000000000000043371305333611600261150ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library provides a function to compute the rigid/flex status --- of a FlatCurry expression (right-hand side of a function definition). --- --- @author Michael Hanus --- @version April 2005 --- @category meta ------------------------------------------------------------------------------ module FlatCurry.FlexRigid(FlexRigidResult(..),getFlexRigid) where import FlatCurry.Types --- Datatype for representing a flex/rigid status of an expression. data FlexRigidResult = UnknownFR | ConflictFR | KnownFlex | KnownRigid --- Computes the rigid/flex status of a FlatCurry expression. --- This function checks all cases in this expression. --- If the expression has rigid as well as flex cases (which cannot --- be the case for source level programs but might occur after --- some program transformations), the result ConflictFR is returned. getFlexRigid :: Expr -> FlexRigidResult getFlexRigid (Var _) = UnknownFR getFlexRigid (Lit _) = UnknownFR getFlexRigid (Comb _ _ args) = foldr joinCaseTypes UnknownFR (map getFlexRigid args) getFlexRigid (Let _ e) = getFlexRigid e getFlexRigid (Free _ e) = getFlexRigid e getFlexRigid (Or e1 e2) = joinCaseTypes (getFlexRigid e1) (getFlexRigid e2) getFlexRigid (Case ctype e bs) = foldr joinCaseTypes (if ctype==Flex then KnownFlex else KnownRigid) (map getFlexRigid (e : map (\(Branch _ be)->be) bs)) getFlexRigid (Typed e _) = getFlexRigid e joinCaseTypes ConflictFR ConflictFR = ConflictFR joinCaseTypes ConflictFR UnknownFR = ConflictFR joinCaseTypes ConflictFR KnownFlex = ConflictFR joinCaseTypes ConflictFR KnownRigid = ConflictFR joinCaseTypes UnknownFR ConflictFR = ConflictFR joinCaseTypes KnownFlex ConflictFR = ConflictFR joinCaseTypes KnownRigid ConflictFR = ConflictFR joinCaseTypes UnknownFR UnknownFR = UnknownFR joinCaseTypes UnknownFR KnownFlex = KnownFlex joinCaseTypes UnknownFR KnownRigid = KnownRigid joinCaseTypes KnownFlex UnknownFR = KnownFlex joinCaseTypes KnownFlex KnownFlex = KnownFlex joinCaseTypes KnownFlex KnownRigid = ConflictFR joinCaseTypes KnownRigid UnknownFR = KnownRigid joinCaseTypes KnownRigid KnownFlex = ConflictFR joinCaseTypes KnownRigid KnownRigid = KnownRigid curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/FlatCurry/Goodies.curry000066400000000000000000000701511305333611600256260ustar00rootroot00000000000000---------------------------------------------------------------------------- --- This library provides selector functions, test and update operations --- as well as some useful auxiliary functions for FlatCurry data terms. --- Most of the provided functions are based on general transformation --- functions that replace constructors with user-defined --- functions. For recursive datatypes the transformations are defined --- inductively over the term structure. This is quite usual for --- transformations on FlatCurry terms, --- so the provided functions can be used to implement specific transformations --- without having to explicitly state the recursion. Essentially, the tedious --- part of such transformations - descend in fairly complex term structures - --- is abstracted away, which hopefully makes the code more clear and brief. --- --- @author Sebastian Fischer --- @version October 2015 --- @category meta ---------------------------------------------------------------------------- module FlatCurry.Goodies where import FlatCurry.Types type Update a b = (b -> b) -> a -> a -- Prog ---------------------------------------------------------------------- --- transform program trProg :: (String -> [String] -> [TypeDecl] -> [FuncDecl] -> [OpDecl] -> a) -> Prog -> a trProg prog (Prog name imps types funcs ops) = prog name imps types funcs ops -- Selectors --- get name from program progName :: Prog -> String progName = trProg (\name _ _ _ _ -> name) --- get imports from program progImports :: Prog -> [String] progImports = trProg (\_ imps _ _ _ -> imps) --- get type declarations from program progTypes :: Prog -> [TypeDecl] progTypes = trProg (\_ _ types _ _ -> types) --- get functions from program progFuncs :: Prog -> [FuncDecl] progFuncs = trProg (\_ _ _ funcs _ -> funcs) --- get infix operators from program progOps :: Prog -> [OpDecl] progOps = trProg (\_ _ _ _ ops -> ops) -- Update Operations --- update program updProg :: (String -> String) -> ([String] -> [String]) -> ([TypeDecl] -> [TypeDecl]) -> ([FuncDecl] -> [FuncDecl]) -> ([OpDecl] -> [OpDecl]) -> Prog -> Prog updProg fn fi ft ff fo = trProg prog where prog name imps types funcs ops = Prog (fn name) (fi imps) (ft types) (ff funcs) (fo ops) --- update name of program updProgName :: Update Prog String updProgName f = updProg f id id id id --- update imports of program updProgImports :: Update Prog [String] updProgImports f = updProg id f id id id --- update type declarations of program updProgTypes :: Update Prog [TypeDecl] updProgTypes f = updProg id id f id id --- update functions of program updProgFuncs :: Update Prog [FuncDecl] updProgFuncs f = updProg id id id f id --- update infix operators of program updProgOps :: Update Prog [OpDecl] updProgOps = updProg id id id id -- Auxiliary Functions --- get all program variables (also from patterns) allVarsInProg :: Prog -> [VarIndex] allVarsInProg = concatMap allVarsInFunc . progFuncs --- lift transformation on expressions to program updProgExps :: Update Prog Expr updProgExps = updProgFuncs . map . updFuncBody --- rename programs variables rnmAllVarsInProg :: Update Prog VarIndex rnmAllVarsInProg = updProgFuncs . map . rnmAllVarsInFunc --- update all qualified names in program updQNamesInProg :: Update Prog QName updQNamesInProg f = updProg id id (map (updQNamesInType f)) (map (updQNamesInFunc f)) (map (updOpName f)) --- rename program (update name of and all qualified names in program) rnmProg :: String -> Prog -> Prog rnmProg name p = updProgName (const name) (updQNamesInProg rnm p) where rnm (mod,n) | mod==progName p = (name,n) | otherwise = (mod,n) -- TypeDecl ------------------------------------------------------------------ -- Selectors --- transform type declaration trType :: (QName -> Visibility -> [Int] -> [ConsDecl] -> a) -> (QName -> Visibility -> [Int] -> TypeExpr -> a) -> TypeDecl -> a trType typ _ (Type name vis params cs) = typ name vis params cs trType _ typesyn (TypeSyn name vis params syn) = typesyn name vis params syn --- get name of type declaration typeName :: TypeDecl -> QName typeName = trType (\name _ _ _ -> name) (\name _ _ _ -> name) --- get visibility of type declaration typeVisibility :: TypeDecl -> Visibility typeVisibility = trType (\_ vis _ _ -> vis) (\_ vis _ _ -> vis) --- get type parameters of type declaration typeParams :: TypeDecl -> [TVarIndex] typeParams = trType (\_ _ params _ -> params) (\_ _ params _ -> params) --- get constructor declarations from type declaration typeConsDecls :: TypeDecl -> [ConsDecl] typeConsDecls = trType (\_ _ _ cs -> cs) failed --- get synonym of type declaration typeSyn :: TypeDecl -> TypeExpr typeSyn = trType failed (\_ _ _ syn -> syn) --- is type declaration a type synonym? isTypeSyn :: TypeDecl -> Bool isTypeSyn = trType (\_ _ _ _ -> False) (\_ _ _ _ -> True) -- Update Operations --- update type declaration updType :: (QName -> QName) -> (Visibility -> Visibility) -> ([Int] -> [Int]) -> ([ConsDecl] -> [ConsDecl]) -> (TypeExpr -> TypeExpr) -> TypeDecl -> TypeDecl updType fn fv fp fc fs = trType typ typesyn where typ name vis params cs = Type (fn name) (fv vis) (fp params) (fc cs) typesyn name vis params syn = TypeSyn (fn name) (fv vis) (fp params) (fs syn) --- update name of type declaration updTypeName :: Update TypeDecl QName updTypeName f = updType f id id id id --- update visibility of type declaration updTypeVisibility :: Update TypeDecl Visibility updTypeVisibility f = updType id f id id id --- update type parameters of type declaration updTypeParams :: Update TypeDecl [TVarIndex] updTypeParams f = updType id id f id id --- update constructor declarations of type declaration updTypeConsDecls :: Update TypeDecl [ConsDecl] updTypeConsDecls f = updType id id id f id --- update synonym of type declaration updTypeSynonym :: Update TypeDecl TypeExpr updTypeSynonym = updType id id id id -- Auxiliary Functions --- update all qualified names in type declaration updQNamesInType :: Update TypeDecl QName updQNamesInType f = updType f id id (map (updQNamesInConsDecl f)) (updQNamesInTypeExpr f) -- ConsDecl ------------------------------------------------------------------ -- Selectors --- transform constructor declaration trCons :: (QName -> Int -> Visibility -> [TypeExpr] -> a) -> ConsDecl -> a trCons cons (Cons name arity vis args) = cons name arity vis args --- get name of constructor declaration consName :: ConsDecl -> QName consName = trCons (\name _ _ _ -> name) --- get arity of constructor declaration consArity :: ConsDecl -> Int consArity = trCons (\_ arity _ _ -> arity) --- get visibility of constructor declaration consVisibility :: ConsDecl -> Visibility consVisibility = trCons (\_ _ vis _ -> vis) --- get arguments of constructor declaration consArgs :: ConsDecl -> [TypeExpr] consArgs = trCons (\_ _ _ args -> args) -- Update Operations --- update constructor declaration updCons :: (QName -> QName) -> (Int -> Int) -> (Visibility -> Visibility) -> ([TypeExpr] -> [TypeExpr]) -> ConsDecl -> ConsDecl updCons fn fa fv fas = trCons cons where cons name arity vis args = Cons (fn name) (fa arity) (fv vis) (fas args) --- update name of constructor declaration updConsName :: Update ConsDecl QName updConsName f = updCons f id id id --- update arity of constructor declaration updConsArity :: Update ConsDecl Int updConsArity f = updCons id f id id --- update visibility of constructor declaration updConsVisibility :: Update ConsDecl Visibility updConsVisibility f = updCons id id f id --- update arguments of constructor declaration updConsArgs :: Update ConsDecl [TypeExpr] updConsArgs = updCons id id id -- Auxiliary Functions --- update all qualified names in constructor declaration updQNamesInConsDecl :: Update ConsDecl QName updQNamesInConsDecl f = updCons f id id (map (updQNamesInTypeExpr f)) -- TypeExpr ------------------------------------------------------------------ -- Selectors --- get index from type variable tVarIndex :: TypeExpr -> TVarIndex tVarIndex texpr = case texpr of (TVar n) -> n _ -> error "FlatCurryGoodies.tVarIndex: no type variable" --- get domain from functional type domain :: TypeExpr -> TypeExpr domain texpr = case texpr of (FuncType dom _) -> dom _ -> error "FlatCurryGoodies.domain: no functional type" --- get range from functional type range :: TypeExpr -> TypeExpr range texpr = case texpr of (FuncType _ ran) -> ran _ -> error "FlatCurryGoodies.range: no functional type" --- get name from constructed type tConsName :: TypeExpr -> QName tConsName texpr = case texpr of (TCons name _) -> name _ -> error "FlatCurryGoodies.tConsName: no constructed type" --- get arguments from constructed type tConsArgs :: TypeExpr -> [TypeExpr] tConsArgs texpr = case texpr of (TCons _ args) -> args _ -> error "FlatCurryGoodies.tConsArgs: no constructed type" --- transform type expression trTypeExpr :: (Int -> a) -> (QName -> [a] -> a) -> (a -> a -> a) -> TypeExpr -> a trTypeExpr tvar _ _ (TVar n) = tvar n trTypeExpr tvar tcons functype (TCons name args) = tcons name (map (trTypeExpr tvar tcons functype) args) trTypeExpr tvar tcons functype (FuncType from to) = functype (f from) (f to) where f = trTypeExpr tvar tcons functype -- Test Operations --- is type expression a type variable? isTVar :: TypeExpr -> Bool isTVar = trTypeExpr (\_ -> True) (\_ _ -> False) (\_ _ -> False) --- is type declaration a constructed type? isTCons :: TypeExpr -> Bool isTCons = trTypeExpr (\_ -> False) (\_ _ -> True) (\_ _ -> False) --- is type declaration a functional type? isFuncType :: TypeExpr -> Bool isFuncType = trTypeExpr (\_ -> False) (\_ _ -> False) (\_ _ -> True) -- Update Operations --- update all type variables updTVars :: (Int -> TypeExpr) -> TypeExpr -> TypeExpr updTVars tvar = trTypeExpr tvar TCons FuncType --- update all type constructors updTCons :: (QName -> [TypeExpr] -> TypeExpr) -> TypeExpr -> TypeExpr updTCons tcons = trTypeExpr TVar tcons FuncType --- update all functional types updFuncTypes :: (TypeExpr -> TypeExpr -> TypeExpr) -> TypeExpr -> TypeExpr updFuncTypes = trTypeExpr TVar TCons -- Auxiliary Functions --- get argument types from functional type argTypes :: TypeExpr -> [TypeExpr] argTypes (TVar _) = [] argTypes (TCons _ _) = [] argTypes (FuncType dom ran) = dom : argTypes ran --- get result type from (nested) functional type resultType :: TypeExpr -> TypeExpr resultType (TVar n) = TVar n resultType (TCons name args) = TCons name args resultType (FuncType _ ran) = resultType ran --- rename variables in type expression rnmAllVarsInTypeExpr :: (Int -> Int) -> TypeExpr -> TypeExpr rnmAllVarsInTypeExpr f = updTVars (TVar . f) --- update all qualified names in type expression updQNamesInTypeExpr :: (QName -> QName) -> TypeExpr -> TypeExpr updQNamesInTypeExpr f = updTCons (\name args -> TCons (f name) args) -- OpDecl -------------------------------------------------------------------- --- transform operator declaration trOp :: (QName -> Fixity -> Int -> a) -> OpDecl -> a trOp op (Op name fix prec) = op name fix prec -- Selectors --- get name from operator declaration opName :: OpDecl -> QName opName = trOp (\name _ _ -> name) --- get fixity of operator declaration opFixity :: OpDecl -> Fixity opFixity = trOp (\_ fix _ -> fix) --- get precedence of operator declaration opPrecedence :: OpDecl -> Int opPrecedence = trOp (\_ _ prec -> prec) -- Update Operations --- update operator declaration updOp :: (QName -> QName) -> (Fixity -> Fixity) -> (Int -> Int) -> OpDecl -> OpDecl updOp fn ff fp = trOp op where op name fix prec = Op (fn name) (ff fix) (fp prec) --- update name of operator declaration updOpName :: Update OpDecl QName updOpName f = updOp f id id --- update fixity of operator declaration updOpFixity :: Update OpDecl Fixity updOpFixity f = updOp id f id --- update precedence of operator declaration updOpPrecedence :: Update OpDecl Int updOpPrecedence = updOp id id -- FuncDecl ------------------------------------------------------------------ --- transform function trFunc :: (QName -> Int -> Visibility -> TypeExpr -> Rule -> a) -> FuncDecl -> a trFunc func (Func name arity vis t rule) = func name arity vis t rule -- Selectors --- get name of function funcName :: FuncDecl -> QName funcName = trFunc (\name _ _ _ _ -> name) --- get arity of function funcArity :: FuncDecl -> Int funcArity = trFunc (\_ arity _ _ _ -> arity) --- get visibility of function funcVisibility :: FuncDecl -> Visibility funcVisibility = trFunc (\_ _ vis _ _ -> vis) --- get type of function funcType :: FuncDecl -> TypeExpr funcType = trFunc (\_ _ _ t _ -> t) --- get rule of function funcRule :: FuncDecl -> Rule funcRule = trFunc (\_ _ _ _ rule -> rule) -- Update Operations --- update function updFunc :: (QName -> QName) -> (Int -> Int) -> (Visibility -> Visibility) -> (TypeExpr -> TypeExpr) -> (Rule -> Rule) -> FuncDecl -> FuncDecl updFunc fn fa fv ft fr = trFunc func where func name arity vis t rule = Func (fn name) (fa arity) (fv vis) (ft t) (fr rule) --- update name of function updFuncName :: Update FuncDecl QName updFuncName f = updFunc f id id id id --- update arity of function updFuncArity :: Update FuncDecl Int updFuncArity f = updFunc id f id id id --- update visibility of function updFuncVisibility :: Update FuncDecl Visibility updFuncVisibility f = updFunc id id f id id --- update type of function updFuncType :: Update FuncDecl TypeExpr updFuncType f = updFunc id id id f id --- update rule of function updFuncRule :: Update FuncDecl Rule updFuncRule = updFunc id id id id -- Auxiliary Functions --- is function externally defined? isExternal :: FuncDecl -> Bool isExternal = isRuleExternal . funcRule --- get variable names in a function declaration allVarsInFunc :: FuncDecl -> [Int] allVarsInFunc = allVarsInRule . funcRule --- get arguments of function, if not externally defined funcArgs :: FuncDecl -> [Int] funcArgs = ruleArgs . funcRule --- get body of function, if not externally defined funcBody :: FuncDecl -> Expr funcBody = ruleBody . funcRule funcRHS :: FuncDecl -> [Expr] funcRHS f | not (isExternal f) = orCase (funcBody f) | otherwise = [] where orCase e | isOr e = concatMap orCase (orExps e) | isCase e = concatMap orCase (map branchExpr (caseBranches e)) | otherwise = [e] --- rename all variables in function rnmAllVarsInFunc :: Update FuncDecl VarIndex rnmAllVarsInFunc = updFunc id id id id . rnmAllVarsInRule --- update all qualified names in function updQNamesInFunc :: Update FuncDecl QName updQNamesInFunc f = updFunc f id id (updQNamesInTypeExpr f) (updQNamesInRule f) --- update arguments of function, if not externally defined updFuncArgs :: Update FuncDecl [VarIndex] updFuncArgs = updFuncRule . updRuleArgs --- update body of function, if not externally defined updFuncBody :: Update FuncDecl Expr updFuncBody = updFuncRule . updRuleBody -- Rule ---------------------------------------------------------------------- --- transform rule trRule :: ([Int] -> Expr -> a) -> (String -> a) -> Rule -> a trRule rule _ (Rule args exp) = rule args exp trRule _ ext (External s) = ext s -- Selectors --- get rules arguments if it's not external ruleArgs :: Rule -> [Int] ruleArgs = trRule (\args _ -> args) failed --- get rules body if it's not external ruleBody :: Rule -> Expr ruleBody = trRule (\_ exp -> exp) failed --- get rules external declaration ruleExtDecl :: Rule -> String ruleExtDecl = trRule failed id -- Test Operations --- is rule external? isRuleExternal :: Rule -> Bool isRuleExternal = trRule (\_ _ -> False) (\_ -> True) -- Update Operations --- update rule updRule :: ([Int] -> [Int]) -> (Expr -> Expr) -> (String -> String) -> Rule -> Rule updRule fa fe fs = trRule rule ext where rule args exp = Rule (fa args) (fe exp) ext s = External (fs s) --- update rules arguments updRuleArgs :: Update Rule [VarIndex] updRuleArgs f = updRule f id id --- update rules body updRuleBody :: Update Rule Expr updRuleBody f = updRule id f id --- update rules external declaration updRuleExtDecl :: Update Rule String updRuleExtDecl f = updRule id id f -- Auxiliary Functions --- get variable names in a functions rule allVarsInRule :: Rule -> [Int] allVarsInRule = trRule (\args body -> args ++ allVars body) (\_ -> []) --- rename all variables in rule rnmAllVarsInRule :: Update Rule VarIndex rnmAllVarsInRule f = updRule (map f) (rnmAllVars f) id --- update all qualified names in rule updQNamesInRule :: Update Rule QName updQNamesInRule = updRuleBody . updQNames -- CombType ------------------------------------------------------------------ --- transform combination type trCombType :: a -> (Int -> a) -> a -> (Int -> a) -> CombType -> a trCombType fc _ _ _ FuncCall = fc trCombType _ fpc _ _ (FuncPartCall n) = fpc n trCombType _ _ cc _ ConsCall = cc trCombType _ _ _ cpc (ConsPartCall n) = cpc n -- Test Operations --- is type of combination FuncCall? isCombTypeFuncCall :: CombType -> Bool isCombTypeFuncCall = trCombType True (\_ -> False) False (\_ -> False) --- is type of combination FuncPartCall? isCombTypeFuncPartCall :: CombType -> Bool isCombTypeFuncPartCall = trCombType False (\_ -> True) False (\_ -> False) --- is type of combination ConsCall? isCombTypeConsCall :: CombType -> Bool isCombTypeConsCall = trCombType False (\_ -> False) True (\_ -> False) --- is type of combination ConsPartCall? isCombTypeConsPartCall :: CombType -> Bool isCombTypeConsPartCall = trCombType False (\_ -> False) False (\_ -> True) -- Auxiliary Functions missingArgs :: CombType -> Int missingArgs = trCombType 0 id 0 id -- Expr ---------------------------------------------------------------------- -- Selectors --- get internal number of variable varNr :: Expr -> Int varNr expr = case expr of (Var n) -> n _ -> error "FlatCurryGoodies.varNr: no variable" --- get literal if expression is literal expression literal :: Expr -> Literal literal expr = case expr of (Lit l) -> l _ -> error "FlatCurryGoodies.literal: no literal" --- get combination type of a combined expression combType :: Expr -> CombType combType expr = case expr of (Comb ct _ _) -> ct _ -> error "FlatCurryGoodies.combType: no combined expression" --- get name of a combined expression combName :: Expr -> QName combName expr = case expr of (Comb _ name _) -> name _ -> error "FlatCurryGoodies.combName: no combined expression" --- get arguments of a combined expression combArgs :: Expr -> [Expr] combArgs expr = case expr of (Comb _ _ args) -> args _ -> error "FlatCurryGoodies.combArgs: no combined expression" --- get number of missing arguments if expression is combined missingCombArgs :: Expr -> Int missingCombArgs = missingArgs . combType --- get indices of variables in let declaration letBinds :: Expr -> [(Int,Expr)] letBinds expr = case expr of (Let vs _) -> vs _ -> error "FlatCurryGoodies.letBinds: no let declaration" --- get body of let declaration letBody :: Expr -> Expr letBody expr = case expr of (Let _ e) -> e _ -> error "FlatCurryGoodies.letBody: no let declaration" --- get variable indices from declaration of free variables freeVars :: Expr -> [Int] freeVars expr = case expr of (Free vs _) -> vs _ -> error "FlatCurryGoodies.freeVars: no free variable declaration" --- get expression from declaration of free variables freeExpr :: Expr -> Expr freeExpr expr = case expr of (Free _ e) -> e _ -> error "FlatCurryGoodies.freeExpr: no free variable declaration" --- get expressions from or-expression orExps :: Expr -> [Expr] orExps expr = case expr of (Or e1 e2) -> [e1,e2] _ -> error "FlatCurryGoodies.orExps: no or-expression" --- get case-type of case expression caseType :: Expr -> CaseType caseType expr = case expr of (Case ct _ _) -> ct _ -> error "FlatCurryGoodies.caseType: no case expression" --- get scrutinee of case expression caseExpr :: Expr -> Expr caseExpr expr = case expr of (Case _ e _) -> e _ -> error "FlatCurryGoodies.caseExpr: no case expression" --- get branch expressions from case expression caseBranches :: Expr -> [BranchExpr] caseBranches expr = case expr of (Case _ _ bs) -> bs _ -> error "FlatCurryGoodies.caseBranches: no case expression" -- Test Operations --- is expression a variable? isVar :: Expr -> Bool isVar e = case e of Var _ -> True _ -> False --- is expression a literal expression? isLit :: Expr -> Bool isLit e = case e of Lit _ -> True _ -> False --- is expression combined? isComb :: Expr -> Bool isComb e = case e of Comb _ _ _ -> True _ -> False --- is expression a let expression? isLet :: Expr -> Bool isLet e = case e of Let _ _ -> True _ -> False --- is expression a declaration of free variables? isFree :: Expr -> Bool isFree e = case e of Free _ _ -> True _ -> False --- is expression an or-expression? isOr :: Expr -> Bool isOr e = case e of Or _ _ -> True _ -> False --- is expression a case expression? isCase :: Expr -> Bool isCase e = case e of Case _ _ _ -> True _ -> False --- transform expression trExpr :: (Int -> a) -> (Literal -> a) -> (CombType -> QName -> [a] -> a) -> ([(Int,a)] -> a -> a) -> ([Int] -> a -> a) -> (a -> a -> a) -> (CaseType -> a -> [b] -> a) -> (Pattern -> a -> b) -> (a -> TypeExpr -> a) -> Expr -> a trExpr var _ _ _ _ _ _ _ _ (Var n) = var n trExpr _ lit _ _ _ _ _ _ _ (Lit l) = lit l trExpr var lit comb lt fr or cas branch typed (Comb ct name args) = comb ct name (map (trExpr var lit comb lt fr or cas branch typed) args) trExpr var lit comb lt fr or cas branch typed (Let bs e) = lt (map (\ (n,exp) -> (n,f exp)) bs) (f e) where f = trExpr var lit comb lt fr or cas branch typed trExpr var lit comb lt fr or cas branch typed (Free vs e) = fr vs (trExpr var lit comb lt fr or cas branch typed e) trExpr var lit comb lt fr or cas branch typed (Or e1 e2) = or (f e1) (f e2) where f = trExpr var lit comb lt fr or cas branch typed trExpr var lit comb lt fr or cas branch typed (Case ct e bs) = cas ct (f e) (map (\ (Branch pat exp) -> branch pat (f exp)) bs) where f = trExpr var lit comb lt fr or cas branch typed trExpr var lit comb lt fr or cas branch typed (Typed e ty) = typed (trExpr var lit comb lt fr or cas branch typed e) ty -- Update Operations --- update all variables in given expression updVars :: (Int -> Expr) -> Expr -> Expr updVars var = trExpr var Lit Comb Let Free Or Case Branch Typed --- update all literals in given expression updLiterals :: (Literal -> Expr) -> Expr -> Expr updLiterals lit = trExpr Var lit Comb Let Free Or Case Branch Typed --- update all combined expressions in given expression updCombs :: (CombType -> QName -> [Expr] -> Expr) -> Expr -> Expr updCombs comb = trExpr Var Lit comb Let Free Or Case Branch Typed --- update all let expressions in given expression updLets :: ([(Int,Expr)] -> Expr -> Expr) -> Expr -> Expr updLets lt = trExpr Var Lit Comb lt Free Or Case Branch Typed --- update all free declarations in given expression updFrees :: ([Int] -> Expr -> Expr) -> Expr -> Expr updFrees fr = trExpr Var Lit Comb Let fr Or Case Branch Typed --- update all or expressions in given expression updOrs :: (Expr -> Expr -> Expr) -> Expr -> Expr updOrs or = trExpr Var Lit Comb Let Free or Case Branch Typed --- update all case expressions in given expression updCases :: (CaseType -> Expr -> [BranchExpr] -> Expr) -> Expr -> Expr updCases cas = trExpr Var Lit Comb Let Free Or cas Branch Typed --- update all case branches in given expression updBranches :: (Pattern -> Expr -> BranchExpr) -> Expr -> Expr updBranches branch = trExpr Var Lit Comb Let Free Or Case branch Typed --- update all typed expressions in given expression updTypeds :: (Expr -> TypeExpr -> Expr) -> Expr -> Expr updTypeds typed = trExpr Var Lit Comb Let Free Or Case Branch typed -- Auxiliary Functions --- is expression a call of a function where all arguments are provided? isFuncCall :: Expr -> Bool isFuncCall e = isComb e && isCombTypeFuncCall (combType e) --- is expression a partial function call? isFuncPartCall :: Expr -> Bool isFuncPartCall e = isComb e && isCombTypeFuncPartCall (combType e) --- is expression a call of a constructor? isConsCall :: Expr -> Bool isConsCall e = isComb e && isCombTypeConsCall (combType e) --- is expression a partial constructor call? isConsPartCall :: Expr -> Bool isConsPartCall e = isComb e && isCombTypeConsPartCall (combType e) --- is expression fully evaluated? isGround :: Expr -> Bool isGround exp = case exp of Comb ConsCall _ args -> all isGround args _ -> isLit exp --- get all variables (also pattern variables) in expression allVars :: Expr -> [Int] allVars e = trExpr (:) (const id) comb lt fr (.) cas branch const e [] where comb _ _ = foldr (.) id lt bs exp = exp . foldr (.) id (map (\ (n,ns) -> (n:) . ns) bs) fr vs exp = (vs++) . exp cas _ exp bs = exp . foldr (.) id bs branch pat exp = ((args pat)++) . exp args pat | isConsPattern pat = patArgs pat | otherwise = [] --- rename all variables (also in patterns) in expression rnmAllVars :: Update Expr Int rnmAllVars f = trExpr (Var . f) Lit Comb lt (Free . map f) Or Case branch Typed where lt = Let . map (\ (n,exp) -> (f n,exp)) branch = Branch . updPatArgs (map f) --- update all qualified names in expression updQNames :: Update Expr QName updQNames f = trExpr Var Lit comb Let Free Or Case (Branch . updPatCons f) typed where comb ct name args = Comb ct (f name) args typed e ty = Typed e (updQNamesInTypeExpr f ty) -- BranchExpr ---------------------------------------------------------------- --- transform branch expression trBranch :: (Pattern -> Expr -> a) -> BranchExpr -> a trBranch branch (Branch pat exp) = branch pat exp -- Selectors --- get pattern from branch expression branchPattern :: BranchExpr -> Pattern branchPattern = trBranch (\pat _ -> pat) --- get expression from branch expression branchExpr :: BranchExpr -> Expr branchExpr = trBranch (\_ e -> e) -- Update Operations --- update branch expression updBranch :: (Pattern -> Pattern) -> (Expr -> Expr) -> BranchExpr -> BranchExpr updBranch fp fe = trBranch branch where branch pat exp = Branch (fp pat) (fe exp) --- update pattern of branch expression updBranchPattern :: Update BranchExpr Pattern updBranchPattern f = updBranch f id --- update expression of branch expression updBranchExpr :: Update BranchExpr Expr updBranchExpr = updBranch id -- Pattern ------------------------------------------------------------------- --- transform pattern trPattern :: (QName -> [Int] -> a) -> (Literal -> a) -> Pattern -> a trPattern pattern _ (Pattern name args) = pattern name args trPattern _ lpattern (LPattern l) = lpattern l -- Selectors --- get name from constructor pattern patCons :: Pattern -> QName patCons = trPattern (\name _ -> name) failed --- get arguments from constructor pattern patArgs :: Pattern -> [Int] patArgs = trPattern (\_ args -> args) failed --- get literal from literal pattern patLiteral :: Pattern -> Literal patLiteral = trPattern failed id -- Test Operations --- is pattern a constructor pattern? isConsPattern :: Pattern -> Bool isConsPattern = trPattern (\_ _ -> True) (\_ -> False) -- Update Operations --- update pattern updPattern :: (QName -> QName) -> ([Int] -> [Int]) -> (Literal -> Literal) -> Pattern -> Pattern updPattern fn fa fl = trPattern pattern lpattern where pattern name args = Pattern (fn name) (fa args) lpattern l = LPattern (fl l) --- update constructors name of pattern updPatCons :: (QName -> QName) -> Pattern -> Pattern updPatCons f = updPattern f id id --- update arguments of constructor pattern updPatArgs :: ([Int] -> [Int]) -> Pattern -> Pattern updPatArgs f = updPattern id f id --- update literal of pattern updPatLiteral :: (Literal -> Literal) -> Pattern -> Pattern updPatLiteral f = updPattern id id f -- Auxiliary Functions --- build expression from pattern patExpr :: Pattern -> Expr patExpr = trPattern (\ name -> Comb ConsCall name . map Var) Lit curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/FlatCurry/Pretty.curry000066400000000000000000000264501305333611600255270ustar00rootroot00000000000000--- -------------------------------------------------------------------------- --- This library provides pretty-printers for FlatCurry modules --- and all substructures (e.g., expressions). --- --- @author Bjoern Peemoeller --- @version June 2015 --- @category meta --- -------------------------------------------------------------------------- module FlatCurry.Pretty where import Pretty import FlatCurry.Types --- Options for pretty printing --- @field indentWidth - number of columns for indentation of substructures --- @field qualMode - Qualification mode of pretty printer --- @field currentModule - Name of current module to be pretty-printed, used --- for proper qualification data Options = Options { indentWidth :: Int , qualMode :: QualMode , currentModule :: String } --- Qualification mode, determines whether identifiers are printed qualified --- or unqualified. While `QualNone` and `QualImports` aim at readability, --- there may be ambiguities due to shadowing. On the contrary, `QualImports` --- and `QualAll` produce correct output at the cost of readability. --- --- @cons QualNone - no qualification, only unqualified names --- @cons QualImportsButPrelude - qualify all imports except those from --- the module `Prelude` --- @cons QualImports - qualify all imports, including `Prelude` --- @cons QualAll - qualify all names data QualMode = QualNone | QualImportsButPrelude | QualImports | QualAll --- Default `Options` for pretty-printing. defaultOptions :: Options defaultOptions = Options { indentWidth = 2 , qualMode = QualImportsButPrelude , currentModule = "" } -- --------------------------------------------------------------------------- -- Pretty printing of Flat modules -- --------------------------------------------------------------------------- --- pretty-print a FlatCurry module ppProg :: Options -> Prog -> Doc ppProg o (Prog m is ts fs os) = vsepBlank [ ppHeader o' m ts fs , ppImports o' is , ppOpDecls o' os , ppTypeDecls o' ts , ppFuncDecls o' fs ] where o' = o { currentModule = m } --- pretty-print the module header ppHeader :: Options -> String -> [TypeDecl] -> [FuncDecl] -> Doc ppHeader o m ts fs = indent o $ sep [text "module" <+> text m, ppExports o ts fs, text "where"] --- pretty-print the export list ppExports :: Options -> [TypeDecl] -> [FuncDecl] -> Doc ppExports o ts fs = tupledSpaced (map (ppTypeExport o) ts ++ ppFuncExports o fs) --- pretty-print a type export ppTypeExport :: Options -> TypeDecl -> Doc ppTypeExport o (Type qn vis _ cs) | vis == Private = empty | null cs = ppPrefixQOp o qn | all isPublicCons cs = ppPrefixQOp o qn <+> text "(..)" | otherwise = ppPrefixQOp o qn <+> tupled (ppConsExports o cs) where isPublicCons (Cons _ _ v _) = v == Public ppTypeExport o (TypeSyn qn vis _ _ ) | vis == Private = empty | otherwise = ppPrefixQOp o qn --- pretty-print the export list of constructors ppConsExports :: Options -> [ConsDecl] -> [Doc] ppConsExports o cs = [ ppPrefixQOp o qn | Cons qn _ Public _ <- cs] --- pretty-print the export list of functions ppFuncExports :: Options -> [FuncDecl] -> [Doc] ppFuncExports o fs = [ ppPrefixQOp o qn | Func qn _ Public _ _ <- fs] --- pretty-print a list of import statements ppImports :: Options -> [String] -> Doc ppImports o = vsep . map (ppImport o) --- pretty-print a single import statement ppImport :: Options -> String -> Doc ppImport o m = indent o $ text "import" <+> text m --- pretty-print a list of operator fixity declarations ppOpDecls :: Options -> [OpDecl] -> Doc ppOpDecls o = vsep . map (ppOpDecl o) --- pretty-print a single operator fixity declaration ppOpDecl :: Options -> OpDecl -> Doc ppOpDecl o (Op qn fix n) = indent o $ ppFixity fix <+> int n <+> ppInfixQOp o qn --- pretty-print the associativity keyword ppFixity :: Fixity -> Doc ppFixity InfixOp = text "infix" ppFixity InfixlOp = text "infixl" ppFixity InfixrOp = text "infixr" --- pretty-print a list of type declarations ppTypeDecls :: Options -> [TypeDecl] -> Doc ppTypeDecls o = vsepBlank . map (ppTypeDecl o) --- pretty-print a type declaration ppTypeDecl :: Options -> TypeDecl -> Doc ppTypeDecl o (Type qn _ vs cs) = indent o $ (text "data" <+> ppName qn <+> hsep (empty : map ppTVarIndex vs)) $$ ppConsDecls o cs ppTypeDecl o (TypeSyn qn _ vs ty) = indent o $ text "type" <+> ppName qn <+> hsep (empty : map ppTVarIndex vs) equals <+> ppTypeExp o ty --- pretty-print the constructor declarations ppConsDecls :: Options -> [ConsDecl] -> Doc ppConsDecls o cs = vsep $ zipWith (<+>) (equals : repeat bar) (map (ppConsDecl o) cs) --- pretty print a single constructor ppConsDecl :: Options -> ConsDecl -> Doc ppConsDecl o (Cons qn _ _ tys) = hsep $ ppPrefixOp qn : map (ppTypeExpr o 2) tys --- pretty a top-level type expression ppTypeExp :: Options -> TypeExpr -> Doc ppTypeExp o = ppTypeExpr o 0 --- pretty-print a type expression ppTypeExpr :: Options -> Int -> TypeExpr -> Doc ppTypeExpr _ _ (TVar v) = ppTVarIndex v ppTypeExpr o p (FuncType ty1 ty2) = parensIf (p > 0) $ ppTypeExpr o 1 ty1 rarrow <+> ppTypeExp o ty2 ppTypeExpr o p (TCons qn tys) | isListId qn && length tys == 1 = brackets (ppTypeExp o (head tys)) | isTupleId qn = tupled (map (ppTypeExp o) tys) | otherwise = parensIf (p > 1 && not (null tys)) $ sep (ppPrefixQOp o qn : map (ppTypeExpr o 2) tys) --- pretty-print a type variable ppTVarIndex :: TVarIndex -> Doc ppTVarIndex i = text $ vars !! i where vars = [ chr c : if n == 0 then [] else show n | n <- [0 ..], c <- [ord 'a' .. ord 'z'] ] --- pretty-print a list of function declarations ppFuncDecls :: Options -> [FuncDecl] -> Doc ppFuncDecls o = vsepBlank . map (ppFuncDecl o) --- pretty-print a function declaration ppFuncDecl :: Options -> FuncDecl -> Doc ppFuncDecl o (Func qn _ _ ty r) = indent o (sep [ppPrefixOp qn, text "::", ppTypeExp o ty]) $$ indent o (ppPrefixOp qn <+> ppRule o r) --- pretty-print a function rule ppRule :: Options -> Rule -> Doc ppRule o (Rule vs e) | null vs = equals <+> ppExp o e | otherwise = hsep (map ppVarIndex vs) equals <+> ppExp o e ppRule _ (External e) = text "external" <+> dquotes (text e) --- Pretty-print a top-level expression. ppExp :: Options -> Expr -> Doc ppExp o = ppExpr o 0 --- pretty-print an expression ppExpr :: Options -> Int -> Expr -> Doc ppExpr _ _ (Var v) = ppVarIndex v ppExpr _ _ (Lit l) = ppLiteral l ppExpr o p (Comb _ qn es) = ppComb o p qn es ppExpr o p (Free vs e) | null vs = ppExpr o p e | otherwise = parensIf (p > 0) $ sep [ text "let" <+> sep (punctuate comma (map ppVarIndex vs)) <+> text "free" , text "in" ppExp o e ] ppExpr o p (Let ds e) = parensIf (p > 0) $ sep [ text "let" <+> ppDecls o ds , text "in" <+> ppExp o e ] ppExpr o p (Or e1 e2) = parensIf (p > 0) $ ppExpr o 1 e1 <+> text "?" <+> ppExpr o 1 e2 ppExpr o p (Case ct e bs) = parensIf (p > 0) $ indent o $ ppCaseType ct <+> ppExpr o 1 e <+> text "of" $$ vsep (map (ppBranch o) bs) ppExpr o p (Typed e ty) = parensIf (p > 0) $ ppExp o e <+> text "::" <+> ppTypeExp o ty --- pretty-print a variable ppVarIndex :: VarIndex -> Doc ppVarIndex i | i < 0 = text $ 'x' : show (negate i) | otherwise = text $ 'v' : show i --- pretty-print a literal ppLiteral :: Literal -> Doc ppLiteral (Intc i) = int i ppLiteral (Floatc f) = float f ppLiteral (Charc c) = text (show c) --- Pretty print a constructor or function call ppComb :: Options -> Int -> QName -> [Expr] -> Doc ppComb o p qn es | isListId qn && null es = text "[]" | isTupleId qn = tupled (map (ppExp o) es) | otherwise = case es of [] -> ppPrefixQOp o qn [e1,e2] | isInfixOp qn -> parensIf (p > 0) $ fillSep [ppExpr o 1 e1, ppInfixQOp o qn, ppExpr o 1 e2] _ -> parensIf (p > 0) $ fillSep (ppPrefixQOp o qn : map (ppExpr o 1) es) --- pretty-print a list of declarations ppDecls :: Options -> [(VarIndex, Expr)] -> Doc ppDecls o = align . vsep . map (ppDecl o) --- pretty-print a single declaration ppDecl :: Options -> (VarIndex, Expr) -> Doc ppDecl o (v, e) = ppVarIndex v <+> equals <+> ppExp o e --- Pretty print the type of a case expression ppCaseType :: CaseType -> Doc ppCaseType Rigid = text "case" ppCaseType Flex = text "fcase" --- Pretty print a case branch ppBranch :: Options -> BranchExpr -> Doc ppBranch o (Branch p e) = ppPattern o p <+> rarrow <+> indent o (ppExp o e) --- Pretty print a pattern ppPattern :: Options -> Pattern -> Doc ppPattern o (Pattern c vs) | isListId c && null vs = text "[]" | isTupleId c = tupled (map ppVarIndex vs) | otherwise = case vs of [v1,v2] | isInfixOp c -> ppVarIndex v1 <+> ppInfixQOp o c <+> ppVarIndex v2 _ -> hsep (ppPrefixQOp o c : map ppVarIndex vs) ppPattern _ (LPattern l) = ppLiteral l -- --------------------------------------------------------------------------- -- Names -- --------------------------------------------------------------------------- --- pretty-print a qualified prefix operator. ppPrefixQOp :: Options -> QName -> Doc ppPrefixQOp o qn = parensIf (isInfixOp qn) (ppQName o qn) --- pretty-print a prefix operator unqualified. ppPrefixOp :: QName -> Doc ppPrefixOp qn = parensIf (isInfixOp qn) (ppName qn) --- pretty-print an infix operator ppInfixQOp :: Options -> QName -> Doc ppInfixQOp o qn = if isInfixOp qn then ppQName o qn else bquotes (ppQName o qn) --- Pretty-print a qualified name ppQName :: Options -> QName -> Doc ppQName o qn@(m, i) | null m = text i | isConsId qn || isListId qn || isTupleId qn = text i | q == QualNone = text i | q == QualImportsButPrelude && (m == m' || m == "Prelude") = text i | q == QualImports && m == m' = text i | otherwise = text $ m ++ '.' : i where q = qualMode o m' = currentModule o --- Pretty-print a qualified name unqualified (e.g., for type definitions). ppName :: QName -> Doc ppName (_, i) = text i --- Check whether an operator is an infix operator isInfixOp :: QName -> Bool isInfixOp = all (`elem` "~!@#$%^&*+-=<>:?./|\\") . snd --- Check whether an identifier represents the `:` list constructor. isConsId :: QName -> Bool isConsId (m, i) = m `elem` ["Prelude", ""] && i == ":" --- Check whether an identifier represents a list isListId :: QName -> Bool isListId (m, i) = m `elem` ["Prelude", ""] && i == "[]" --- Check whether an identifier represents a tuple isTupleId :: QName -> Bool isTupleId (m, i) = m `elem` ["Prelude", ""] && i == mkTuple (length i) where mkTuple n = '(' : replicate (n - 2) ',' ++ ")" --- Indentation indent :: Options -> Doc -> Doc indent o d = nest (indentWidth o) d curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/FlatCurry/Read.curry000066400000000000000000000162411305333611600251100ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library defines operations to read a FlatCurry programs or interfaces --- together with all its imported modules in the current load path. --- --- @author Michael Hanus, Bjoern Peemoeller --- @version December 2016 --- @category meta ------------------------------------------------------------------------------ module FlatCurry.Read ( readFlatCurryInPath , readFlatCurryWithImports , readFlatCurryWithImportsInPath , readFlatCurryIntWithImports , readFlatCurryIntWithImportsInPath ) where import Directory (getModificationTime) import Distribution ( getLoadPathForModule, lookupModuleSource , FrontendTarget (FCY), callFrontendWithParams , defaultParams, setQuiet, setFullPath ) import FileGoodies (baseName, lookupFileInPath, stripSuffix) import FilePath (normalise) import FlatCurry.Types import FlatCurry.Files --- Reads a FlatCurry program together in a given load path. --- The arguments are a load path and the name of the module. readFlatCurryInPath :: [String] -> String -> IO Prog readFlatCurryInPath loadpath modname = do [prog] <- readFlatCurryFileInPath False False loadpath modname [".fcy"] return prog --- Reads a FlatCurry program together with all its imported modules. --- The argument is the name of the main module, --- possibly with a directory prefix. readFlatCurryWithImports :: String -> IO [Prog] readFlatCurryWithImports modname = do loadpath <- getLoadPathForModule modname readFlatCurryFileInPath True False loadpath (baseName modname) [".fcy"] --- Reads a FlatCurry program together with all its imported modules --- in a given load path. --- The arguments are a load path and the name of the main module. readFlatCurryWithImportsInPath :: [String] -> String -> IO [Prog] readFlatCurryWithImportsInPath loadpath modname = readFlatCurryFileInPath True False loadpath modname [".fcy"] --- Reads a FlatCurry interface together with all its imported module --- interfaces. --- The argument is the name of the main module, --- possibly with a directory prefix. --- If there is no interface file but a FlatCurry file (suffix ".fcy"), --- the FlatCurry file is read instead of the interface. readFlatCurryIntWithImports :: String -> IO [Prog] readFlatCurryIntWithImports modname = do loadpath <- getLoadPathForModule modname readFlatCurryFileInPath True False loadpath (baseName modname) [".fint",".fcy"] --- Reads a FlatCurry interface together with all its imported module interfaces --- in a given load path. --- The arguments are a load path and the name of the main module. --- If there is no interface file but a FlatCurry file (suffix ".fcy"), --- the FlatCurry file is read instead of the interface. readFlatCurryIntWithImportsInPath :: [String] -> String -> IO [Prog] readFlatCurryIntWithImportsInPath loadpath modname = readFlatCurryFileInPath True False loadpath modname [".fint",".fcy"] -- Read a FlatCurry file (together with its imported modules if the first -- argument is true). -- The further arguments are the verbosity mode, the loadpath, -- the name of the main module, and the possible suffixes -- of the FlatCurry file (e.g., [".fint",".fcy"]). readFlatCurryFileInPath :: Bool -> Bool -> [String] -> String -> [String] -> IO [Prog] readFlatCurryFileInPath withImp verb loadpath mod sfxs = do when verb $ putStr "Reading FlatCurry files " -- try to read the interface files directly eiMods <- tryReadFlatCurryFile withImp verb loadpath mod sfxs either (\_ -> parseFlatCurryFile withImp verb loadpath mod sfxs) return eiMods -- Parse a FlatCurry file together with its imported modules. -- The argument is the loadpath, the name of the main module, and the -- possible suffixes of the FlatCurry file (e.g., [".fint",".fcy"]). parseFlatCurryFile :: Bool -> Bool -> [String] -> String -> [String] -> IO [Prog] parseFlatCurryFile withImp verb loadpath modname suffixes = do when verb $ putStrLn $ ">>>>> FlatCurry files not up-to-date, parsing module \"" ++ modname ++ "\"..." callFrontendWithParams FCY (setQuiet True (setFullPath loadpath defaultParams)) modname when verb $ putStr "Reading FlatCurry files " eiMods <- tryReadFlatCurryFile withImp verb loadpath modname suffixes return (either (error . notFound) id eiMods) where notFound mods = "FlatCurry file not found for the following module(s): " ++ unwords mods -- Read a FlatCurry file (with all its imports if first argument is true). -- If all files could be read, -- then `Right progs` is returned, otherwise `Left mods` where `mods` is -- the list of modules that could *not* be read. tryReadFlatCurryFile :: Bool -> Bool -> [String] -> String -> [String] -> IO (Either [String] [Prog]) tryReadFlatCurryFile withImp verb loadpath modname suffixes = if withImp then tryReadFlatCurryFileWithImports verb loadpath modname suffixes else do mProg <- tryReadFlatCurry verb loadpath modname suffixes return $ maybe (Left [modname]) (Right . (:[])) mProg -- Read a FlatCurry file with all its imports. If all files could be read, -- then `Right progs` is returned, otherwise `Left mods` where `mods` is -- the list of modules that could *not* be read. tryReadFlatCurryFileWithImports :: Bool -> [String] -> String -> [String] -> IO (Either [String] [Prog]) tryReadFlatCurryFileWithImports verb loadpath modname suffixes = collect [modname] [] where -- Collects all imported modules collect [] _ = when verb (putStrLn "done") >> return (Right []) collect (mod:mods) implist | mod `elem` implist = collect mods implist | otherwise = do mbProg <- tryReadFlatCurry verb loadpath mod suffixes case mbProg of Nothing -> return (Left [mod]) Just prog@(Prog _ is _ _ _) -> do mbresults <- collect (mods ++ is) (mod:implist) return (either Left (Right . (prog :)) mbresults) -- Read a single FlatCurry file for a module if it exists and is up-to-date -- w.r.t. the source program. If no source exists, it is always assumed -- to be up-to-date. If the source is newer then the FlatCurry file or -- there is no FlatCurry file, the function returns `Nothing`. tryReadFlatCurry :: Bool -> [String] -> String -> [String] -> IO (Maybe Prog) tryReadFlatCurry verb loadpath modname suffixes = do mbSrc <- lookupModuleSource loadpath modname case mbSrc of Nothing -> lookupFileInPath flatbasename suffixes loadpath >>= maybe (return Nothing) (liftIO Just . readFlatCurryFile) Just (_,src) -> do mbFcy <- lookupFileInPath flatbasename suffixes loadpath case mbFcy of Nothing -> return Nothing Just fcy -> do ctime <- getModificationTime src ftime <- getModificationTime fcy if ctime > ftime then return Nothing else do when verb $ putStr (normalise fcy ++ " ") Just `liftIO` readFlatCurryFile fcy where flatbasename = stripSuffix (flatCurryFileName modname) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/FlatCurry/Show.curry000066400000000000000000000312121305333611600251500ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library contains operations to transform FlatCurry programs --- into string representations, either in a FlatCurry format or --- in a Curry-like syntax. --- --- This library contains --- --- * show functions for a string representation of FlatCurry programs --- (`showFlatProg`, `showFlatType`, `showFlatFunc`) --- * functions for showing FlatCurry (type) expressions in (almost) --- Curry syntax (`showCurryType`, `showCurryExpr`,...). --- --- @author Michael Hanus --- @version October 2015 --- @category meta ------------------------------------------------------------------------------ module FlatCurry.Show(showFlatProg,showFlatType,showFlatFunc, showCurryType,showCurryExpr,showCurryId,showCurryVar) where import FlatCurry.Types import List import Char --- Shows a FlatCurry program term as a string (with some pretty printing). showFlatProg :: Prog -> String showFlatProg (Prog modname imports types funcs ops) = " (Prog " ++ show modname ++ (if null imports then "\n []" else "\n [" ++ showFlatListElems show imports ++ "]") ++ (if null types then "\n []" else "\n [" ++ showFlatListElems showFlatType types ++ "\n ]") ++ "\n [" ++ showFlatListElems showFlatFunc funcs ++ "\n ]" ++ "\n " ++ showFlatList showFlatOp ops ++ "\n )\n" showFlatVisibility Public = " Public " showFlatVisibility Private = " Private " showFlatFixity InfixOp = " InfixOp " showFlatFixity InfixlOp = " InfixlOp " showFlatFixity InfixrOp = " InfixrOp " showFlatOp (Op name fix prec) = "(Op " ++ show name ++ showFlatFixity fix ++ show prec ++ ")" showFlatType :: TypeDecl -> String showFlatType (Type name vis tpars consdecls) = "\n (Type " ++ show name ++ showFlatVisibility vis ++ showFlatList show tpars ++ showFlatList showFlatCons consdecls ++ ")" showFlatType (TypeSyn name vis tpars texp) = "\n (TypeSyn " ++ show name ++ showFlatVisibility vis ++ showFlatList show tpars ++ showFlatTypeExpr texp ++ ")" showFlatCons (Cons cname arity vis types) = "(Cons " ++ show cname ++ " " ++ show arity ++ showFlatVisibility vis ++ showFlatList showFlatTypeExpr types ++ ")" showFlatFunc :: FuncDecl -> String showFlatFunc (Func name arity vis ftype rl) = "\n (Func " ++ show name ++ " " ++ show arity ++ " " ++ showFlatVisibility vis ++ "\n " ++ showFlatTypeExpr ftype ++ "\n " ++ showFlatRule rl ++ ")" showFlatRule (Rule params expr) = " (Rule " ++ showFlatList show params ++ showFlatExpr expr ++ ")" showFlatRule (External name) = " (External " ++ show name ++ ")" showFlatTypeExpr (FuncType t1 t2) = "(FuncType " ++ showFlatTypeExpr t1 ++ " " ++ showFlatTypeExpr t2 ++ ")" showFlatTypeExpr (TCons tc ts) = "(TCons " ++ show tc ++ showFlatList showFlatTypeExpr ts ++ ")" showFlatTypeExpr (TVar n) = "(TVar " ++ show n ++ ")" showFlatCombType FuncCall = "FuncCall" showFlatCombType ConsCall = "ConsCall" showFlatCombType (FuncPartCall n) = "(FuncPartCall " ++ show n ++ ")" showFlatCombType (ConsPartCall n) = "(ConsPartCall " ++ show n ++ ")" showFlatExpr (Var n) = "(Var " ++ show n ++ ")" showFlatExpr (Lit l) = "(Lit " ++ showFlatLit l ++ ")" showFlatExpr (Comb ctype cf es) = "(Comb " ++ showFlatCombType ctype ++ " " ++ show cf ++ showFlatList showFlatExpr es ++ ")" showFlatExpr (Let bindings exp) = "(Let " ++ showFlatList showFlatBinding bindings ++ showFlatExpr exp ++ ")" where showFlatBinding (x,e) = "("++show x++","++showFlatExpr e++")" showFlatExpr (Free xs e) = "(Free " ++ showFlatList show xs ++ showFlatExpr e ++ ")" showFlatExpr (Or e1 e2) = "(Or " ++ showFlatExpr e1 ++ " " ++ showFlatExpr e2 ++ ")" showFlatExpr (Case Rigid e bs) = "(Case Rigid " ++ showFlatExpr e ++ showFlatList showFlatBranch bs ++ ")" showFlatExpr (Case Flex e bs) = "(Case Flex " ++ showFlatExpr e ++ showFlatList showFlatBranch bs ++ ")" showFlatExpr (Typed e ty) = "(Typed " ++ showFlatExpr e ++ ' ' : showFlatTypeExpr ty ++ ")" showFlatLit (Intc i) = "(Intc " ++ show i ++ ")" showFlatLit (Floatc f) = "(Floatc " ++ show f ++ ")" showFlatLit (Charc c) = "(Charc " ++ show c ++ ")" showFlatBranch (Branch p e) = "(Branch " ++ showFlatPattern p ++ showFlatExpr e ++ ")" showFlatPattern (Pattern qn xs) = "(Pattern " ++ show qn ++ showFlatList show xs ++ ")" showFlatPattern (LPattern lit) = "(LPattern " ++ showFlatLit lit ++ ")" -- format a finite list of elements: showFlatList :: (a->String) -> [a] -> String showFlatList format elems = " [" ++ showFlatListElems format elems ++ "] " showFlatListElems :: (a->String) -> [a] -> String showFlatListElems format elems = concat (intersperse "," (map format elems)) ------------------------------------------------------------------------------ --- Shows a FlatCurry type in Curry syntax. --- --- @param trans - a translation function from qualified type names --- to external type names --- @param nested - True iff brackets must be written around complex types --- @param texpr - the FlatCurry type expression to be formatted --- @return the String representation of the formatted type expression showCurryType :: ((String,String) -> String) -> Bool -> TypeExpr -> String showCurryType _ _ (TVar i) = if i<5 then [chr (97+i)] else 't':show i showCurryType tf nested (FuncType t1 t2) = showBracketsIf nested (showCurryType tf (isFuncType t1) t1 ++ " -> " ++ showCurryType tf False t2) showCurryType tf nested (TCons tc ts) | null ts = tf tc | tc==("Prelude","[]") && (head ts == TCons ("Prelude","Char") []) = "String" | tc==("Prelude","[]") = "[" ++ showCurryType tf False (head ts) ++ "]" -- list type | take 2 (snd tc) == "(," -- tuple type = "(" ++ concat (intersperse "," (map (showCurryType tf False) ts)) ++ ")" | otherwise = showBracketsIf nested (tf tc ++ concatMap (\t->' ':showCurryType tf True t) ts) isFuncType (TVar _) = False isFuncType (FuncType _ _) = True isFuncType (TCons _ _) = False ------------------------------------------------------------------------------ --- Shows a FlatCurry expressions in (almost) Curry syntax. --- --- @param trans - a translation function from qualified functions names --- to external function names --- @param nested - True iff brackets must be written around complex terms --- @param indent - the indentation used in case expressions and if-then-else --- @param expr - the FlatCurry expression to be formatted --- @return the String representation of the formatted expression showCurryExpr :: ((String,String) -> String) -> Bool -> Int -> Expr -> String showCurryExpr _ _ _ (Var n) = showCurryVar n showCurryExpr _ _ _ (Lit l) = showCurryLit l showCurryExpr tf _ _ (Comb _ cf []) = showCurryId (tf cf) showCurryExpr tf nested b (Comb _ cf [e]) = showBracketsIf nested (showCurryId (tf cf) ++ " " ++ showCurryExpr tf True b e) showCurryExpr tf nested b (Comb ct cf [e1,e2]) | cf==("Prelude","apply") = showBracketsIf nested (showCurryExpr tf True b e1 ++ " " ++ showCurryExpr tf True b e2) | isAlpha (head (snd cf)) = showBracketsIf nested (tf cf ++" "++ showCurryElems (showCurryExpr tf True b) [e1,e2]) | isFiniteList (Comb ct cf [e1,e2]) = if isStringConstant (Comb ct cf [e1,e2]) then "\"" ++ showCurryStringConstant (Comb ct cf [e1,e2]) ++ "\"" else "[" ++ concat (intersperse "," (showCurryFiniteList tf b (Comb ct cf [e1,e2]))) ++ "]" | snd cf == "(,)" -- pair constructor? = "(" ++ showCurryExpr tf False b e1 ++ "," ++ showCurryExpr tf False b e2 ++ ")" | otherwise = showBracketsIf nested (showCurryExpr tf True b e1 ++ " " ++ tf cf ++ " " ++ showCurryExpr tf True b e2 ) showCurryExpr tf nested b (Comb _ cf (e1:e2:e3:es)) | cf==("Prelude","if_then_else") && null es = showBracketsIf nested ("\n" ++ sceBlanks b ++ " if " ++ showCurryExpr tf False (b+2) e1 ++ "\n" ++ sceBlanks b ++ " then " ++ showCurryExpr tf False (b+2) e2 ++ "\n" ++ sceBlanks b ++ " else " ++ showCurryExpr tf False (b+2) e3) | take 2 (snd cf) == "(," -- tuple constructor? = "(" ++ concat (intersperse "," (map (showCurryExpr tf False b) (e1:e2:e3:es))) ++ ")" | otherwise = showBracketsIf nested (showCurryId (tf cf) ++ " " ++ showCurryElems (showCurryExpr tf True b) (e1:e2:e3:es)) showCurryExpr tf nested b (Let bindings exp) = showBracketsIf nested ("\n"++sceBlanks b++"let " ++ concat (intersperse ("\n "++sceBlanks b) (map (\ (x,e)->showCurryVar x ++" = "++showCurryExpr tf False (b+4) e) bindings)) ++ ("\n"++sceBlanks b++" in ") ++ showCurryExpr tf False (b+4) exp) showCurryExpr tf nested b (Free [] e) = showCurryExpr tf nested b e showCurryExpr tf nested b (Free (x:xs) e) = showBracketsIf nested ("let " ++ concat (intersperse "," (map showCurryVar (x:xs))) ++ " free in " ++ showCurryExpr tf False b e) showCurryExpr tf nested b (Or e1 e2) = showBracketsIf nested (showCurryExpr tf True b e1 ++ " ? " ++ showCurryExpr tf True b e2) showCurryExpr tf nested b (Case ctype e cs) = showBracketsIf nested ((case ctype of Rigid -> "case " Flex -> "fcase ") ++ showCurryExpr tf True b e ++ " of\n " ++ showCurryElems (showCurryCase tf (b+2)) cs ++ sceBlanks b) showCurryExpr tf nested b (Typed e ty) = showBracketsIf nested (showCurryExpr tf True b e ++ " :: " ++ showCurryType tf False ty) showCurryVar i = "v" ++ show i --- Shows an identifier in Curry form. Thus, operators are enclosed in brackets. showCurryId name | isAlpha (head name) = name | name == "[]" = name | otherwise = ('(':name)++")" showCurryLit (Intc i) = show i showCurryLit (Floatc f) = show f showCurryLit (Charc c) = show c showCurryCase tf b (Branch (Pattern l vs) e) = sceBlanks b ++ showPattern (tf l) vs ++ " -> " ++ showCurryExpr tf False b e ++ "\n" where showPattern c [] = c showPattern c [x] = c ++ " " ++ showCurryVar x showPattern c [x1,x2] = if isAlpha (head c) then c ++ " " ++ showCurryVar x1 ++ " " ++ showCurryVar x2 else if c=="(,)" -- pair constructor? then "(" ++ showCurryVar x1 ++ "," ++ showCurryVar x2 ++ ")" else showCurryVar x1 ++ " " ++ c ++ " " ++ showCurryVar x2 showPattern c (x1:x2:x3:xs) = if take 2 c == "(," -- tuple constructor? then "("++ concat (intersperse "," (map showCurryVar (x1:x2:x3:xs))) ++")" else c ++ " " ++ showCurryElems showCurryVar (x1:x2:x3:xs) showCurryCase tf b (Branch (LPattern l) e) = sceBlanks b ++ showCurryLit l ++ " " ++ " -> " ++ showCurryExpr tf False b e ++ "\n" showCurryFiniteList _ _ (Comb _ ("Prelude","[]") []) = [] showCurryFiniteList tf b (Comb _ ("Prelude",":") [e1,e2]) = showCurryExpr tf False b e1 : showCurryFiniteList tf b e2 -- show a string constant showCurryStringConstant (Comb _ ("Prelude","[]") []) = [] showCurryStringConstant (Comb _ ("Prelude",":") [e1,e2]) = showCharExpr e1 ++ showCurryStringConstant e2 showCharExpr (Lit (Charc c)) | c=='"' = "\\\"" | c=='\'' = "\\\'" | c=='\n' = "\\n" | o < 32 || o > 126 = ['\\',chr(o `div` 100 + 48), chr(((o `mod` 100) `div` 10 + 48)),chr(o `mod` 10 + 48)] | otherwise = [c] where o = ord c showCurryElems :: (a->String) -> [a] -> String showCurryElems format elems = concat (intersperse " " (map format elems)) showBracketsIf nested s = if nested then '(' : s ++ ")" else s sceBlanks b = take b (repeat ' ') -- Is the expression a finite list (with an empty list at the end)? isFiniteList :: Expr -> Bool isFiniteList (Var _) = False isFiniteList (Lit _) = False isFiniteList (Comb _ name args) | name==("Prelude","[]") && null args = True | name==("Prelude",":") && length args == 2 = isFiniteList (args!!1) | otherwise = False isFiniteList (Let _ _) = False isFiniteList (Free _ _) = False isFiniteList (Or _ _) = False isFiniteList (Case _ _ _) = False -- Is the expression a string constant? isStringConstant :: Expr -> Bool isStringConstant e = case e of Comb _ name args -> (name==("Prelude","[]") && null args) || (name==("Prelude",":") && length args == 2 && isCharConstant (head args) && isStringConstant (args!!1)) _ -> False -- Is the expression a character constant? isCharConstant :: Expr -> Bool isCharConstant e = case e of Lit (Charc _) -> True _ -> False ------------------------------------------------------------------------------ curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/FlatCurry/Types.curry000066400000000000000000000204541305333611600253420ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library supports meta-programming, i.e., the manipulation of --- Curry programs in Curry. For this purpose, the library contains --- definitions of data types for the representation of --- so-called FlatCurry programs. --- --- @author Michael Hanus --- @version July 2016 --- @category meta ------------------------------------------------------------------------------ module FlatCurry.Types where --- Data type for representing a Curry module in the intermediate form. --- A value of this data type has the form --- --- (Prog modname imports typedecls functions opdecls) --- --- where --- `modname` is the name of this module, --- `imports` is the list of modules names that are imported, and --- `typedecls`, `functions`, and `opdecls` are the list of --- data type, function, and operator declarations --- contained in this module, respectively. data Prog = Prog String [String] [TypeDecl] [FuncDecl] [OpDecl] --- The data type for representing qualified names. --- In FlatCurry all names are qualified to avoid name clashes. --- The first component is the module name and the second component the --- unqualified name as it occurs in the source program. type QName = (String, String) --- Data type to specify the visibility of various entities. data Visibility = Public -- public (exported) entity | Private -- private entity --- The data type for representing type variables. --- They are represented by `(TVar i)` where `i` is a type variable index. type TVarIndex = Int --- Data type for representing definitions of algebraic data types --- and type synonyms. --- --- A data type definition of the form --- --- data t x1...xn = ...| c t1....tkc |... --- --- is represented by the FlatCurry term --- --- (Type t [i1,...,in] [...(Cons c kc [t1,...,tkc])...]) --- --- where each `ij` is the index of the type variable `xj`. --- --- Note: the type variable indices are unique inside each type declaration --- and are usually numbered from 0 --- --- Thus, a data type declaration consists of the name of the data type, --- a list of type parameters and a list of constructor declarations. data TypeDecl = Type QName Visibility [TVarIndex] [ConsDecl] | TypeSyn QName Visibility [TVarIndex] TypeExpr --- A constructor declaration consists of the name and arity of the --- constructor and a list of the argument types of the constructor. data ConsDecl = Cons QName Int Visibility [TypeExpr] --- Data type for type expressions. --- A type expression is either a type variable, a function type, --- or a type constructor application. --- --- Note: the names of the predefined type constructors are --- "Int", "Float", "Bool", "Char", "IO", --- "()" (unit type), "(,...,)" (tuple types), "[]" (list type) data TypeExpr = TVar TVarIndex -- type variable | FuncType TypeExpr TypeExpr -- function type t1->t2 | TCons QName [TypeExpr] -- type constructor application -- TCons module name typeargs --- Data type for operator declarations. --- An operator declaration `fix p n` in Curry corresponds to the --- FlatCurry term `(Op n fix p)`. data OpDecl = Op QName Fixity Int --- Data types for the different choices for the fixity of an operator. data Fixity = InfixOp | InfixlOp | InfixrOp --- Data type for representing object variables. --- Object variables occurring in expressions are represented by `(Var i)` --- where `i` is a variable index. type VarIndex = Int --- Arity of a function. type Arity = Int --- Data type for representing function declarations. --- --- A function declaration in FlatCurry is a term of the form --- --- (Func name k type (Rule [i1,...,ik] e)) --- --- and represents the function `name` with definition --- --- name :: type --- name x1...xk = e --- --- where each `ij` is the index of the variable `xj`. --- --- Note: the variable indices are unique inside each function declaration --- and are usually numbered from 0 --- --- External functions are represented as --- --- (Func name arity type (External s)) --- --- where s is the external name associated to this function. --- --- Thus, a function declaration consists of the name, arity, type, and rule. data FuncDecl = Func QName Arity Visibility TypeExpr Rule --- A rule is either a list of formal parameters together with an expression --- or an "External" tag. data Rule = Rule [VarIndex] Expr | External String --- Data type for classifying case expressions. --- Case expressions can be either flexible or rigid in Curry. data CaseType = Rigid | Flex -- type of a case expression --- Data type for classifying combinations --- (i.e., a function/constructor applied to some arguments). --- @cons FuncCall - a call to a function where all arguments are provided --- @cons ConsCall - a call with a constructor at the top, all arguments are provided --- @cons FuncPartCall - a partial call to a function (i.e., not all arguments --- are provided) where the parameter is the number of --- missing arguments --- @cons ConsPartCall - a partial call to a constructor (i.e., not all arguments --- are provided) where the parameter is the number of --- missing arguments data CombType = FuncCall | ConsCall | FuncPartCall Arity | ConsPartCall Arity --- Data type for representing expressions. --- --- Remarks: --- --- if-then-else expressions are represented as rigid case expressions: --- --- (if e1 then e2 else e3) --- --- is represented as --- --- (case e1 of { True -> e2; False -> e3}) --- --- Higher-order applications are represented as calls to the (external) --- function `apply`. For instance, the rule --- --- app f x = f x --- --- is represented as --- --- (Rule [0,1] (Comb FuncCall ("Prelude","apply") [Var 0, Var 1])) --- --- A conditional rule is represented as a call to an external function --- `cond` where the first argument is the condition (a constraint). --- For instance, the rule --- --- equal2 x | x=:=2 = True --- --- is represented as --- --- (Rule [0] --- (Comb FuncCall ("Prelude","cond") --- [Comb FuncCall ("Prelude","=:=") [Var 0, Lit (Intc 2)], --- Comb FuncCall ("Prelude","True") []])) --- --- @cons Var - variable (represented by unique index) --- @cons Lit - literal (Int/Float/Char constant) --- @cons Comb - application `(f e1 ... en)` of function/constructor `f` --- with `n`<=arity(`f`) --- @cons Let - introduction of local variables via (recursive) let declarations --- @cons Free - introduction of free local variables --- @cons Or - disjunction of two expressions (used to translate rules --- with overlapping left-hand sides) --- @cons Case - case distinction (rigid or flex) --- @cons Typed - typed expression to represent an expression with a --- type declaration data Expr = Var VarIndex | Lit Literal | Comb CombType QName [Expr] | Let [(VarIndex, Expr)] Expr | Free [VarIndex] Expr | Or Expr Expr | Case CaseType Expr [BranchExpr] | Typed Expr TypeExpr --- Data type for representing branches in a case expression. --- --- Branches "(m.c x1...xn) -> e" in case expressions are represented as --- --- (Branch (Pattern (m,c) [i1,...,in]) e) --- --- where each `ij` is the index of the pattern variable `xj`, or as --- --- (Branch (LPattern (Intc i)) e) --- --- for integers as branch patterns (similarly for other literals --- like float or character constants). data BranchExpr = Branch Pattern Expr --- Data type for representing patterns in case expressions. data Pattern = Pattern QName [VarIndex] | LPattern Literal --- Data type for representing literals occurring in an expression --- or case branch. It is either an integer, a float, or a character constant. data Literal = Intc Int | Floatc Float | Charc Char ----------------------------------------------------------------------- --- Translates a given qualified type name into external name relative to --- a module. Thus, names not defined in this module (except for names --- defined in the prelude) are prefixed with their module name. showQNameInModule :: String -> QName -> String showQNameInModule mod (qmod, name) | qmod == mod || qmod == "Prelude" = name | otherwise = qmod ++ '.' : name curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/FlatCurry/XML.curry000066400000000000000000000103721305333611600246740ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library contains functions to convert FlatCurry programs --- into corresponding XML expressions and vice versa. --- This can be used to store Curry programs in a way independent --- of a Curry system or to use a Curry system, like PAKCS, --- as back end by other functional logic programming systems. --- --- @author Sebastian Fischer --- @version October 2015 --- @category meta ------------------------------------------------------------------------------ {-# OPTIONS_CYMAKE -Wno-incomplete-patterns -Wno-missing-signatures #-} module FlatCurry.XML ( flatCurry2XmlFile, flatCurry2Xml, xmlFile2FlatCurry, xml2FlatCurry ) where import FlatCurry.Types import XML import XmlConv -- URL for the FlatCurry DTD: flatCurryDtd = "http://www.informatik.uni-kiel.de/~curry/flatcurrynew.dtd" --- Transforms a FlatCurry program term into a corresponding XML file. flatCurry2XmlFile :: Prog -> String -> IO () flatCurry2XmlFile flatprog filename = writeFile filename $ showXmlDocWithParams [DtdUrl flatCurryDtd] (flatCurry2Xml flatprog) --- Transforms a FlatCurry program term into a corresponding XML expression. flatCurry2Xml :: Prog -> XmlExp flatCurry2Xml = xmlShow cProg --- Reads an XML file with a FlatCurry program and returns --- the FlatCurry program. xmlFile2FlatCurry :: String -> IO Prog xmlFile2FlatCurry filename = readXmlFile filename >>= return . xml2FlatCurry --- Transforms an XML term into a FlatCurry program. xml2FlatCurry :: XmlExp -> Prog xml2FlatCurry = xmlRead cProg -- FlatCurry XML converter specification: cProg = eSeq5 "prog" Prog cModname cImports cTypes cFuncs cOps cModname = eString "module" cImports = eRep "import" (eString "module") cTypes = eRep "types" cType cType = eSeq4 "type" Type cQName cVis cTParams (rep cConsDecl) ! eSeq4 "typesyn" TypeSyn cQName cVis cTParams cTypeExpr cQName = seq2 (\a b -> (a,b)) (aString "module") (aString "name") cVis = adapt (b2v,v2b) (aBool "visibility" "public" "private") b2v b = if b then Public else Private v2b v = v==Public cTParams = eRep "params" (eInt "tvar") cConsDecl = eSeq4 "cons" Cons cQName cArity cVis (rep cTypeExpr) cArity = aInt "arity" cTypeExpr = eSeq2 "functype" FuncType cTypeExpr cTypeExpr ! eSeq2 "tcons" TCons cQName (rep cTypeExpr) ! eSeq1 "tvar" TVar int cFuncs = eRep "functions" cFunc cFunc = eSeq5 "func" Func cQName cArity cVis cTypeExpr cRule cRule = eSeq2 "rule" Rule cLHS cRHS ! eSeq1 "external" External string cLHS = element "lhs" cVars cRHS = element "rhs" cExpr cVars = rep cVar cVar = eInt "var" cExpr = eSeq1 "var" Var int ! eSeq1 "lit" Lit cLit ! eSeq2 "funccall" fc cQName cExps ! eSeq2 "conscall" cc cQName cExps ! eSeq3 "funcpartcall" pfc cQName cMissing cExps ! eSeq3 "conspartcall" pcc cQName cMissing cExps ! eSeq2 "free" Free (element "freevars" cVars) cExpr ! eSeq2 "or" Or cExpr cExpr ! eSeq2 "case" cr cExpr (rep cBranch) ! eSeq2 "fcase" cf cExpr (rep cBranch) ! eSeq2 "letrec" Let (rep cBind) cExpr ! eSeq2 "typed" Typed cExpr cTypeExpr cLit = eSeq1 "intc" Intc int ! eSeq1 "floatc" Floatc float ! eSeq1 "charc" Charc (adapt (chr,ord) int) fc = Comb FuncCall cc = Comb ConsCall pfc n m = Comb (FuncPartCall m) n pcc n m = Comb (ConsPartCall m) n cExps = rep cExpr cMissing = aInt "missing" cr = Case Rigid cf = Case Flex cBranch = eSeq2 "branch" Branch cPat cExpr cPat = eSeq2 "pattern" Pattern cQName cVars ! eSeq1 "lpattern" LPattern cLit cBind = eSeq2 "binding" (\a b -> (a,b)) cVar cExpr cOps = eRep "operators" cOp cOp = eSeq3 "op" Op cQName cFixity (aInt "prec") cFixity = adapt (rf,show) (aString "fixity") rf "InfixOp" = InfixOp rf "InfixlOp" = InfixlOp rf "InfixrOp" = InfixrOp curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Float.curry000066400000000000000000000103731305333611600233670ustar00rootroot00000000000000------------------------------------------------------------------------------ --- A collection of operations on floating point numbers. --- --- @category general ------------------------------------------------------------------------------ module Float(pi,(+.),(-.),(*.),(/.),(^.),i2f,truncate,round,recip,sqrt,log ,logBase, exp,sin,cos,tan,asin,acos,atan,sinh,cosh,tanh ,asinh,acosh,atanh) where -- The operator declarations are similar to the standard arithmetic operators. infixr 8 ^. infixl 7 *., /. infixl 6 +., -. --- The number pi. pi :: Float pi = 3.141592653589793238 --- Addition on floats. (+.) :: Float -> Float -> Float x +. y = (prim_Float_plus $# y) $# x prim_Float_plus :: Float -> Float -> Float prim_Float_plus external --- Subtraction on floats. (-.) :: Float -> Float -> Float x -. y = (prim_Float_minus $# y) $# x prim_Float_minus :: Float -> Float -> Float prim_Float_minus external --- Multiplication on floats. (*.) :: Float -> Float -> Float x *. y = (prim_Float_times $# y) $# x prim_Float_times :: Float -> Float -> Float prim_Float_times external --- Division on floats. (/.) :: Float -> Float -> Float x /. y = (prim_Float_div $# y) $# x prim_Float_div :: Float -> Float -> Float prim_Float_div external --- The value of `a ^. b` is `a` raised to the power of `b`. --- Executes in `O(log b)` steps. --- --- @param a - The base. --- @param b - The exponent. --- @return `a` raised to the power of `b`. (^.) :: Float -> Int -> Float a ^. b | b < 0 = 1 /. a ^. (b * (-1)) | otherwise = powaux 1.0 a b where powaux n x y = if y == 0 then n else powaux (n *. if (y `mod` 2 == 1) then x else 1.0) (x *. x) (y `div` 2) --- Conversion function from integers to floats. i2f :: Int -> Float i2f x = prim_i2f $# x prim_i2f :: Int -> Float prim_i2f external --- Conversion function from floats to integers. --- The result is the closest integer between the argument and 0. truncate :: Float -> Int truncate x = prim_truncate $# x prim_truncate :: Float -> Int prim_truncate external --- Conversion function from floats to integers. --- The result is the nearest integer to the argument. --- If the argument is equidistant between two integers, --- it is rounded to the closest even integer value. round :: Float -> Int round x = prim_round $# x prim_round :: Float -> Int prim_round external --- Reciprocal recip :: Float -> Float recip x = 1.0 /. x --- Square root. sqrt :: Float -> Float sqrt x = prim_sqrt $# x prim_sqrt :: Float -> Float prim_sqrt external --- Natural logarithm. log :: Float -> Float log x = prim_log $# x prim_log :: Float -> Float prim_log external --- Logarithm to arbitrary Base. logBase :: Float -> Float -> Float logBase x y = log y /. log x --- Natural exponent. exp :: Float -> Float exp x = prim_exp $# x prim_exp :: Float -> Float prim_exp external --- Sine. sin :: Float -> Float sin x = prim_sin $# x prim_sin :: Float -> Float prim_sin external --- Cosine. cos :: Float -> Float cos x = prim_cos $# x prim_cos :: Float -> Float prim_cos external --- Tangent. tan :: Float -> Float tan x = prim_tan $# x prim_tan :: Float -> Float prim_tan external --- Arc sine. asin :: Float -> Float asin x = prim_asin $# x prim_asin :: Float -> Float prim_asin external -- Arc cosine. acos :: Float -> Float acos x = prim_acos $# x prim_acos :: Float -> Float prim_acos external --- Arc tangent. atan :: Float -> Float atan x = prim_atan $# x prim_atan :: Float -> Float prim_atan external --- Hyperbolic sine. sinh :: Float -> Float sinh x = prim_sinh $# x prim_sinh :: Float -> Float prim_sinh external -- Hyperbolic cosine. cosh :: Float -> Float cosh x = prim_cosh $# x prim_cosh :: Float -> Float prim_cosh external --- Hyperbolic tangent. tanh :: Float -> Float tanh x = prim_tanh $# x prim_tanh :: Float -> Float prim_tanh external --- Hyperbolic Arc sine. asinh :: Float -> Float asinh x = prim_asinh $# x prim_asinh :: Float -> Float prim_asinh external -- Hyperbolic Arc cosine. acosh :: Float -> Float acosh x = prim_acosh $# x prim_acosh :: Float -> Float prim_acosh external --- Hyperbolic Arc tangent. atanh :: Float -> Float atanh x = prim_atanh $# x prim_atanh :: Float -> Float prim_atanh external curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Float.prim_c2p000066400000000000000000000052041305333611600237330ustar00rootroot00000000000000 prim_float prim_Float_plus prim_float prim_Float_minus prim_float prim_Float_times prim_float prim_Float_div prim_float prim_i2f prim_float prim_round prim_float prim_truncate prim_float prim_sqrt prim_float prim_log prim_float prim_exp prim_float prim_sin prim_float prim_cos prim_float prim_tan prim_float prim_asin prim_float prim_acos prim_float prim_atan prim_float prim_sinh prim_float prim_cosh prim_float prim_tanh prim_float prim_asinh prim_float prim_acosh prim_float prim_atanh curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Format.curry000066400000000000000000000407501305333611600235540ustar00rootroot00000000000000------------------------------------------------------------------------------ --- The library provides some operations to format values of basic --- data types with arbitrary flags similarly to the `printf` statement of C. --- --- These operations are used for the translation of integrated --- code with the format tag to replace the format specifiers. --- --- This library follows the C specification for the formatting. This --- specification may be found at --- --- --- @author Jasper Sikorra - jsi@informatik.uni-kiel.de --- @version March 2014 --- @category general ------------------------------------------------------------------------------ module Format(showChar,showInt,showFloat,showString) where import Char import Integer import Float import List import ReadNumeric -- Basic type for show functions type ShowSpec a = Typ -> Maybe Flag -> Maybe Width -> Maybe Precision -> a -> String type Typ = Char type Flag = String type Width = Int type Precision = Int --- The function showChar formats a character --- @param type - will be ignored --- @param flags - a string, everything but the minus char will be ignored --- @param width - the minimal number of characters to be printed --- @param precision - will be ignored --- @param char - The char which should be formatted --- @return A string containing the formatted character showChar :: ShowSpec Char showChar _ mf mw _ c = let flags = convertFlags mf width = convertWidth mw minusFlag = getMinusFlag flags cToString = [c] in if minusFlag then fillWithCharsLeftAlign width ' ' cToString else fillWithCharsRightAlign width ' ' cToString --- The function showInt formats an Int --- @param t - A char setting the way of number representation --- @param mf - A string containing all flags --- @param mw - The minimal number of characters to be printed --- @param mp - The minimal number of numbers to be printed --- @param i - The Int which should be formatted --- @return A string containing the formatted Int showInt :: ShowSpec Int showInt t mf mw mp i = -- convert to better format let flags = convertFlags mf width = convertWidth mw prec = convertPrecision mp precPresent = maybe False (\_ -> True) mp minusFlag = getMinusFlag flags plusFlag = getPlusFlag flags zeroFlag = getZeroFlag flags spaceFlag = getSpaceFlag flags hashFlag = getHashFlag flags -- convert to the right numeric system iToString = case t of 'i' -> consistentShowInt i 'd' -> consistentShowInt i 'o' -> showIntAsOct i 'x' -> showIntAsHex i 'X' -> map toUpper (showIntAsHex i) isPositive = head iToString /= '-' isSigned = (||) (t == 'i') (t == 'd') iToStringPosi = if isPositive then iToString else (tail iToString) -- apply precision applyPrecision = fillWithCharsRightAlign prec '0' iToStringPosi afterPrecision = if isPositive then applyPrecision else '-':applyPrecision -- apply flags afterPlusFlag = if (plusFlag && isSigned && isPositive) then '+':afterPrecision else afterPrecision afterHashFlag = if (not (isSigned) && hashFlag && i /= 0) then case t of 'o' -> '0' :afterPlusFlag 'x' -> '0':'x':afterPlusFlag 'X' -> '0':'X':afterPlusFlag else afterPlusFlag afterSpaceFlag = if (spaceFlag && isSigned && isPositive && not plusFlag) then ' ':afterHashFlag else afterHashFlag -- apply width afterWidth = if minusFlag then fillWithCharsLeftAlign width ' ' afterSpaceFlag else let filler = if (zeroFlag && not (precPresent)) then '0' else ' ' in fillWithCharsRightAlign width filler afterSpaceFlag -- result in afterWidth --- The function showFloat formats a Float --- @param t - A char setting wether to use an exponent or not --- @param mf - A string containing all flags --- @param mw - The minimal number of characters to be printed before the point --- @param mp - The exact amount of numbers to be printed after the point --- @param x - The Float which should be formatted --- @return A string containing the formatted float showFloat :: ShowSpec Float showFloat t mf mw mp x = -- convert to better format let flags = convertFlags mf width = convertWidth mw prec = convertPrecision mp minusFlag = getMinusFlag flags plusFlag = getPlusFlag flags zeroFlag = getZeroFlag flags spaceFlag = getSpaceFlag flags hashFlag = getHashFlag flags isPositive = (>=) x 0 -- Convert to Floater format for easier formatting floa = floatToFloater x -- apply type afterType = case t of 'f' -> eliminateExponent floa 'e' -> onePrePoint floa 'E' -> onePrePoint floa -- apply precision afterPrec = roundFloater prec afterType -- apply flags afterPlusFlag = if (plusFlag && x >= 0) then setMantissaBeforePoint afterPrec ('+':getMantissaBeforePoint afterPrec) else afterPrec afterHashFlag = if (not (isPrefixOf (getMantissaAfterPoint afterPlusFlag) (repeat '0')) || hashFlag || prec > 0) then setMantissaAfterPoint afterPlusFlag ('.':getMantissaAfterPoint afterPlusFlag) else afterPlusFlag afterSpaceFlag = if (spaceFlag && not plusFlag && isPositive) then setMantissaBeforePoint afterHashFlag (' ':getMantissaBeforePoint afterHashFlag) else if (not isPositive) then setMantissaBeforePoint afterHashFlag ('-':getMantissaBeforePoint afterHashFlag) else afterHashFlag -- convert back from floater data type unitedFloater = case t of 'f' -> getMantissaBeforePoint afterSpaceFlag ++ getMantissaAfterPoint afterSpaceFlag 'e' -> getMantissaBeforePoint afterSpaceFlag ++ getMantissaAfterPoint afterSpaceFlag ++ "e" ++ showExponent afterSpaceFlag 'E' -> getMantissaBeforePoint afterSpaceFlag ++ getMantissaAfterPoint afterSpaceFlag ++ "E" ++ showExponent afterSpaceFlag -- apply width afterWidth = if minusFlag then fillWithCharsLeftAlign width ' ' unitedFloater else let filler = if zeroFlag then '0' else ' ' in fillWithCharsRightAlign width filler unitedFloater -- result in afterWidth --- The function showString formats a String --- @param t - Ignored --- @param mf - A string containing all flags --- @param mw - The minimal number of characters to be printed --- @param mp - The exact number of characters of the string to be printed --- @param s - The String which should be formatted --- @return A string containing the formatted String showString :: ShowSpec String showString _ mf mw mp s = let flags = convertFlags mf width = convertWidth mw minusFlag = getMinusFlag flags afterPrec = maybe s (flip take s) mp afterWidth = if minusFlag then fillWithCharsLeftAlign width ' ' afterPrec else fillWithCharsRightAlign width ' ' afterPrec in afterWidth --- FLOATER DATA TYPE BEGIN ---------------------- -- Our own datatype for floats, to make manipulating their string representation -- easier data Floater = Floater Sign MantissaBeforePoint MantissaAfterPoint Exponent data Sign = Positive | Negative type MantissaBeforePoint = String type MantissaAfterPoint = String type Mantissa = String type MantissaSigned = String type Exponent = Int floater :: Sign -> MantissaBeforePoint -> MantissaAfterPoint -> Exponent -> Floater floater = Floater floaterCreator :: MantissaSigned -> Exponent -> Floater floaterCreator ms e = setExponent (setMantissaSigned zeroFloater ms) e zeroFloater :: Floater zeroFloater = Floater Positive "0" "" 0 floatToFloater :: Float -> Floater floatToFloater f = let (mantissa,exp) = break ((==) 'e') (consistentShowFloat f) in if (exp == "") then floaterCreator mantissa 0 else floaterCreator mantissa (maybe failed fst (readInt (tail exp))) getSign :: Floater -> Sign getSign (Floater s _ _ _) = s setSign :: Floater -> Sign -> Floater setSign (Floater _ m1 m2 e) s = Floater s m1 m2 e getMantissaBeforePoint :: Floater -> MantissaBeforePoint getMantissaBeforePoint (Floater _ m1 _ _) = m1 setMantissaBeforePoint :: Floater -> MantissaBeforePoint -> Floater setMantissaBeforePoint (Floater s _ m2 e) m1 = Floater s m1 m2 e getMantissaAfterPoint :: Floater -> MantissaAfterPoint getMantissaAfterPoint (Floater _ _ m2 _) = m2 setMantissaAfterPoint :: Floater -> MantissaAfterPoint -> Floater setMantissaAfterPoint (Floater s m1 _ e) m2 = Floater s m1 m2 e getMantissa :: Floater -> Mantissa getMantissa (Floater _ m1 m2 _) = m1 ++ ('.':m2) setMantissa :: Floater -> Mantissa -> Floater setMantissa (Floater s _ _ e) m = let (bP,aP) = break ((==) '.') m in Floater s bP (tail aP) e setMantissaSigned :: Floater -> MantissaSigned -> Floater setMantissaSigned (Floater _ _ _ e) m = let (bP,aP) = break ((==) '.') m in if (head bP == '-') then Floater Negative (tail bP) (tail aP) e else Floater Positive bP (tail aP) e getExponent :: Floater -> Exponent getExponent (Floater _ _ _ e) = e setExponent :: Floater -> Exponent -> Floater setExponent (Floater s m1 m2 _) e = Floater s m1 m2 e showExponent :: Floater -> String showExponent (Floater _ _ _ e) = let st = consistentShowInt e in if (e < -10) then st else if (e < 0 ) then ('-':'0':tail st) else if (e < 10 ) then ('+':'0':st) else ('+':st) eliminateExponent :: Floater -> Floater eliminateExponent (Floater s m1 m2 e) | e == 0 = Floater s m1 m2 e | e > 0 = if (null m2) then eliminateExponent (Floater s (m1 ++ "0") "" (e-1)) else eliminateExponent (Floater s (m1 ++ [(head m2)]) (tail m2) (e-1)) | e < 0 = if (null m1) then eliminateExponent (Floater s "" ("0" ++ m2) (e+1)) else eliminateExponent (Floater s (init m1) ([last m1] ++ m2) (e+1)) onePrePoint :: Floater -> Floater onePrePoint (Floater s m1 m2 e) | m1 == "0" && m2 == "" = Floater s m1 m2 e | m1 == "0" && m2 /= "" = onePrePoint (Floater s [head m2] (tail m2) (e-1)) | m1 /= "0" && length m1 == 1 = Floater s m1 m2 e | m1 /= "0" && length m1 >= 1 = onePrePoint (Floater s (init m1) ((last m1):m2) (e+1)) roundFloater :: Int -> Floater -> Floater roundFloater n (Floater s m1 m2 e) = if (length m2 <= n) then Floater s m1 (m2 ++ replicate (n - length m2) '0') e else Floater s m1 (round (take (n+1) m2)) e round :: String -> String round "" = "" round [_] = "" round st@(_:_:_) = let (con,l) = splitAt (length st-2) st n = digitToInt (head l) r = digitToInt (head (tail l)) in con ++ [if_then_else (r < 5) (intToDigit n) (intToDigit (n+1))] --- FLOATER DATA TYPE END ------------------------ --- HANDLING OF FLAGS BEGIN ---------------------- -- | Handling flags data Flags = Flags Bool -- '-' appears Bool -- '+' appears Bool -- '0' appears Bool -- ' ' appears Bool -- '#' appears getMinusFlag :: Flags -> Bool getMinusFlag (Flags b _ _ _ _) = b getPlusFlag :: Flags -> Bool getPlusFlag (Flags _ b _ _ _) = b getZeroFlag :: Flags -> Bool getZeroFlag (Flags _ _ b _ _) = b getSpaceFlag :: Flags -> Bool getSpaceFlag (Flags _ _ _ b _) = b getHashFlag :: Flags -> Bool getHashFlag (Flags _ _ _ _ b) = b -- Converters of arguments convertFlags :: Maybe String -> Flags convertFlags = maybe (Flags False False False False False) (convFlags (Flags False False False False False)) where convFlags :: Flags -> String -> Flags convFlags f "" = f convFlags (Flags b1 b2 b3 b4 b5) (c:cs) = case c of '-' -> convFlags (Flags True b2 b3 b4 b5 ) cs '+' -> convFlags (Flags b1 True b3 b4 b5 ) cs '0' -> convFlags (Flags b1 b2 True b4 b5 ) cs ' ' -> convFlags (Flags b1 b2 b3 True b5 ) cs '#' -> convFlags (Flags b1 b2 b3 b4 True) cs convertWidth :: Maybe Width -> Int convertWidth = maybe 0 id convertPrecision :: Maybe Int -> Int convertPrecision = maybe 1 id --- HANDLING OF FLAGS END ------------------------ --- FILLING A STRING WITH APPROPRIATE ALIGNMENT data Alignment = LeftAlign | RightAlign fillWithCharsLeftAlign :: Int -> Char -> String -> String fillWithCharsLeftAlign = fillWithChars LeftAlign fillWithCharsRightAlign :: Int -> Char -> String -> String fillWithCharsRightAlign = fillWithChars RightAlign fillWithChars :: Alignment -> Int -> Char -> String -> String fillWithChars a n c st = let i = n - length st in if (i > 0) then if (a == RightAlign) then replicate i c ++ st else st ++ replicate i c else st --- CONSISTENT NUMBER REPRESENTATION AS A STRING ----------- -- The show function on Int and Float is different for pakcs and kics2. -- show -1 -- pakcs: (-1) -- kics2: -1 -- Therefor we need a function that removes the parenthesis. consistentShowInt :: Int -> String consistentShowInt = showWithoutParantheses '(' ')' . show consistentShowFloat :: Float -> String consistentShowFloat = showWithoutParantheses '(' ')' . show showWithoutParantheses :: Char -> Char -> String -> String showWithoutParantheses start_p end_p s = let lengthOfString = length s in if (lengthOfString >= 2) then let (h,t) = splitAt 1 s (r,l) = splitAt (lengthOfString-2) t in if (head h == start_p && head l == end_p) then r else s else s --- CONVERSION OF INTEGERS TO DIFFERENT NUMERATIVE SYSTEMS ----- showIntAsOct :: Int -> String showIntAsOct = convertToBase 8 showIntAsHex :: Int -> String showIntAsHex = convertToBase 16 convertToBase :: Int -> Int -> String convertToBase b n = if (b < 2 || b > 16) then error $ "Can't handle base " ++ (show b) ++ ". Can only handle bases between 2 and 16." else if (n < -2147483647) then error $ "Can only handle integers geq -2147483648." else if (n == 0) then "0" else if (n < 0) then let num = bitNot ((n*(-1))-1) in cTB "" b num else cTB "" b n where cTB :: String -> Int -> Int -> String cTB acc base m = if (m == 0) then acc else let dr = ((div m base),(mod m base)) d = (fst dr) r = (snd dr) st = if (r < 10) then (show r) else case r of 10 -> "a" 11 -> "b" 12 -> "c" 13 -> "d" 14 -> "e" 15 -> "f" in cTB (st ++ acc) b d ------------------------------------------------------------------------------ curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Function.curry000066400000000000000000000024341305333611600241060ustar00rootroot00000000000000--- ---------------------------------------------------------------------------- --- This module provides some utility functions for function application. --- --- @author Bjoern Peemoeller --- @version July 2013 --- @category general --- ---------------------------------------------------------------------------- module Function where --- `fix f` is the least fixed point of the function `f`, --- i.e. the least defined `x` such that `f x = x`. fix :: (a -> a) -> a fix f = let x = f x in x --- `(*) \`on\` f = \\x y -> f x * f y`. --- Typical usage: `sortBy (compare \`on\` fst)`. on :: (b -> b -> c) -> (a -> b) -> a -> a -> c on op f x y = f x `op` f y --- Apply a function to the first component of a tuple. first :: (a -> b) -> (a, c) -> (b, c) first f (x, y) = (f x, y) --- Apply a function to the second component of a tuple. second :: (a -> b) -> (c, a) -> (c, b) second f (x, y) = (x, f y) --- Apply two functions to the two components of a tuple. (***) :: (a -> b) -> (c -> d) -> (a, c) -> (b, d) f *** g = \ (x, y) -> (f x, g y) --- Apply two functions to a value and returns a tuple of the results. (&&&) :: (a -> b) -> (a -> c) -> a -> (b, c) f &&& g = \x -> (f x, g x) --- Apply a function to both components of a tuple. both :: (a -> b) -> (a, a) -> (b, b) both f (x, y) = (f x, f y) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/FunctionInversion.curry000066400000000000000000000020401305333611600257740ustar00rootroot00000000000000--- ---------------------------------------------------------------------------- --- This module provides some utility functions for inverting functions. --- --- @author Michael Hanus --- @version February 2015 --- @category general --- ---------------------------------------------------------------------------- module FunctionInversion where --- Inverts a unary function. invf1 :: (a -> b) -> (b -> a) invf1 f y | f x =:<= y = x where x free --- Inverts a binary function. invf2 :: (a -> b -> c) -> (c -> (a,b)) invf2 f y | f x1 x2 =:<= y = (x1,x2) where x1,x2 free --- Inverts a ternary function. invf3 :: (a -> b -> c -> d) -> (d -> (a,b,c)) invf3 f y | f x1 x2 x3 =:<= y = (x1,x2,x3) where x1,x2,x3 free --- Inverts a function of arity 4. invf4 :: (a -> b -> c -> d -> e) -> (e -> (a,b,c,d)) invf4 f y | f x1 x2 x3 x4 =:<= y = (x1,x2,x3,x4) where x1,x2,x3,x4 free --- Inverts a function of arity 5. invf5 :: (a -> b -> c -> d -> e -> f) -> (f -> (a,b,c,d,e)) invf5 f y | f x1 x2 x3 x4 x5 =:<= y = (x1,x2,x3,x4,x5) where x1,x2,x3,x4,x5 free curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/GUI.curry000066400000000000000000001763211305333611600227540ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library contains definitions and functions to implement --- graphical user interfaces for Curry programs. --- It is based on Tcl/Tk and its basic ideas are described in detail --- [in this paper](http://www.informatik.uni-kiel.de/~mh/papers/PADL00.html) --- --- @authors Michael Hanus, Bernd Brassel --- @version January 2017 --- @category general ------------------------------------------------------------------------------ module GUI(GuiPort,Widget(..),Button,ConfigButton, TextEditScroll,ListBoxScroll,CanvasScroll,EntryScroll, ConfItem(..),ReconfigureItem(..), Cmd,Command,Event(..),ConfCollection(..),MenuItem(..), CanvasItem(..),WidgetRef, Style(..), Color(..), col,row,matrix, runGUI,runGUIwithParams,runInitGUI,runInitGUIwithParams, runPassiveGUI, runControlledGUI,runConfigControlledGUI,runInitControlledGUI, runHandlesControlledGUI,runInitHandlesControlledGUI, exitGUI,getValue,setValue,updateValue,appendValue, appendStyledValue,addRegionStyle,removeRegionStyle, getCursorPosition,seeText, focusInput,addCanvas,setConfig, getOpenFile,getOpenFileWithTypes,getSaveFile,getSaveFileWithTypes, chooseColor,popupMessage,debugTcl) where import Char (isSpace, toUpper) import IO import IOExts (connectToCommand) import Read import System (system) import Unsafe (trace) -- If showTclTkErrors is true, all synchronization errors occuring in the -- Tcl/Tk communication are shown (such errors should only occur on -- slow machines in exceptional cases; they should be handled by this library -- but might be interesting to see for debugging) showTclTkErrors :: Bool showTclTkErrors = False -- If showTclTkCommunication is true, the all strings sent to and from -- the Tcl/Tk GUI are shown in stdout: showTclTkCommunication :: Bool showTclTkCommunication = False --- The port to a GUI is just the stream connection to a GUI --- where Tcl/Tk communication is done. data GuiPort = GuiPort Handle handleOf :: GuiPort -> Handle handleOf (GuiPort h) = h ------------------------------------------------------------------------ -- the basic data types for GUIs: ------------------------------------------------------------------------ --- The type of possible widgets in a GUI. --- @cons PlainButton - a button in a GUI whose event handler is activated --- if the user presses the button --- @cons Canvas - a canvas to draw pictures containing CanvasItems --- @cons CheckButton - a check button: it has value "0" if it is unchecked and --- value "1" if it is checked --- @cons Entry - an entry widget for entering single lines --- @cons Label - a label for showing a text --- @cons ListBox - a widget containing a list of items for selection --- @cons Message - a message for showing simple string values --- @cons MenuButton - a button with a pull-down menu --- @cons Scale - a scale widget to input values by a slider --- @cons ScrollH - a horizontal scroll bar --- @cons ScrollV - a vertical scroll bar --- @cons TextEdit - a text editor widget to show and manipulate larger --- text paragraphs --- @cons Row - a horizontal alignment of widgets --- @cons Col - a vertical alignment of widgets --- @cons Matrix - a 2-dimensional (matrix) alignment of widgets data Widget = PlainButton [ConfItem] | Canvas [ConfItem] | CheckButton [ConfItem] | Entry [ConfItem] | Label [ConfItem] | ListBox [ConfItem] | Message [ConfItem] | MenuButton [ConfItem] | Scale Int Int [ConfItem] | ScrollH WidgetRef [ConfItem] | ScrollV WidgetRef [ConfItem] | TextEdit [ConfItem] | Row [ConfCollection] [Widget] | Col [ConfCollection] [Widget] | Matrix [ConfCollection] [[Widget]] --- The data type for possible configurations of a widget. --- @cons Active - define the active state for buttons, entries, etc. --- @cons Anchor - alignment of information inside a widget where the --- argument must be: n, ne, e, se, s, sw, w, nw, or center --- @cons Background - the background color --- @cons Foreground - the foreground color --- @cons Handler - an event handler associated to a widget. --- The event handler returns a list of widget --- ref/configuration pairs that are applied after the handler --- in order to configure GUI widgets --- @cons Height - the height of a widget (chars for text, pixels for graphics) --- @cons CheckInit - initial value for checkbuttons --- @cons CanvasItems - list of items contained in a canvas --- @cons List - list of values shown in a listbox --- @cons Menu - the items of a menu button --- @cons WRef - a reference to this widget --- @cons Text - an initial text contents --- @cons Width - the width of a widget (chars for text, pixels for graphics) --- @cons Fill - fill widget in both directions --- @cons FillX - fill widget in horizontal direction --- @cons FillY - fill widget in vertical direction --- @cons TclOption - further options in Tcl syntax (unsafe!) data ConfItem = Active Bool | Anchor String | Background String | Foreground String | Handler Event (GuiPort -> IO [ReconfigureItem]) | Height Int | CheckInit String | CanvasItems [CanvasItem] | List [String] | Menu [MenuItem] | WRef WidgetRef | Text String | Width Int | Fill | FillX | FillY | TclOption String isFill :: ConfItem -> Bool isFill ci = case ci of Fill -> True _ -> False isFillX :: ConfItem -> Bool isFillX ci = case ci of FillX -> True _ -> False isFillY :: ConfItem -> Bool isFillY ci = case ci of FillY -> True _ -> False --- Data type for describing configurations that are applied --- to a widget or GUI by some event handler. --- @cons WidgetConf wref conf - reconfigure the widget referred by wref --- with configuration item conf --- @cons StreamHandler hdl handler - add a new handler to the GUI --- that processes inputs on an input stream referred by hdl --- @cons RemoveStreamHandler hdl - remove a handler for an input stream --- referred by hdl from the GUI (usually used to remove handlers --- for closed streams) data ReconfigureItem = WidgetConf WidgetRef ConfItem | StreamHandler Handle (Handle -> GuiPort -> IO [ReconfigureItem]) | RemoveStreamHandler Handle --- The data type of possible events on which handlers can react. --- This list is still incomplete and might be extended or restructured --- in future releases of this library. --- @cons DefaultEvent - the default event of the widget --- @cons MouseButton1 - left mouse button pressed --- @cons MouseButton2 - middle mouse button pressed --- @cons MouseButton3 - right mouse button pressed --- @cons KeyPress - any key is pressed --- @cons Return - return key is pressed data Event = DefaultEvent | MouseButton1 | MouseButton2 | MouseButton3 | KeyPress | Return -- translate event into corresponding Tcl string (except for DefaultEvent) -- with a leading blank: event2tcl :: Event -> String event2tcl DefaultEvent = " default" event2tcl MouseButton1 = " " event2tcl MouseButton2 = " " event2tcl MouseButton3 = " " event2tcl KeyPress = " " event2tcl Return = " " --- The data type for possible configurations of widget collections --- (e.g., columns, rows). --- @cons CenterAlign - centered alignment --- @cons LeftAlign - left alignment --- @cons RightAlign - right alignment --- @cons TopAlign - top alignment --- @cons BottomAlign - bottom alignment data ConfCollection = CenterAlign | LeftAlign | RightAlign | TopAlign | BottomAlign --- The data type for specifying items in a menu. --- @cons MButton - a button with an associated command --- and a label string --- @cons MSeparator - a separator between menu entries --- @cons MMenuButton - a submenu with a label string data MenuItem = MButton (GuiPort -> IO [ReconfigureItem]) String | MSeparator | MMenuButton String [MenuItem] --- The data type of items in a canvas. --- The last argument are further options in Tcl/Tk (for testing). data CanvasItem = CLine [(Int,Int)] String | CPolygon [(Int,Int)] String | CRectangle (Int,Int) (Int,Int) String | COval (Int,Int) (Int,Int) String | CText (Int,Int) String String --- The (hidden) data type of references to a widget in a GUI window. --- Note that the constructor WRefLabel will not be exported so that values --- can only be created inside this module. --- @cons WRefLabel label type - --- "label" is the (globally unique) identifier of --- this widget used in Tk, and "type" is one of --- button / canvas / checkbutton / entry / label / listbox / --- message / scale / scrollbar / textedit data WidgetRef = WRefLabel String String wRef2Label :: WidgetRef -> String wRef2Label (WRefLabel var _) = wRefname2Label var wRef2Wtype :: WidgetRef -> String wRef2Wtype (WRefLabel _ wtype) = wtype --- The data type of possible text styles. --- @cons Bold - text in bold font --- @cons Italic - text in italic font --- @cons Underline - underline text --- @cons Fg - foreground color, i.e., color of the text font --- @cons Bg - background color of the text data Style = Bold | Italic | Underline | Fg Color | Bg Color --- The data type of possible colors. data Color = Black | Blue | Brown | Cyan | Gold | Gray | Green | Magenta | Navy | Orange | Pink | Purple | Red | Tomato| Turquoise | Violet | White | Yellow --- Converts a style value into its textual representation. showStyle :: Style -> String showStyle Bold = "bold" showStyle Italic = "italic" showStyle Underline = "underline" showStyle (Fg fg) = dropSpaces $ showColor fg showStyle (Bg bg) = camelCase $ showColor bg dropSpaces :: String -> String dropSpaces = filter (not . isSpace) camelCase :: String -> String camelCase [] = [] camelCase (c:cs) = toUpper c : cc cs where cc "" = "" cc [x] = [x] cc (x:y:xs) | isSpace x = toUpper y : cc xs | otherwise = x : cc (y:xs) --- Converts a color value into its textual representation. showColor :: Color -> String showColor Black = "black" showColor Blue = "blue" showColor Brown = "brown" showColor Cyan = "cyan" showColor Gold = "gold" showColor Gray = "gray" showColor Green = "forest green" showColor Magenta = "magenta" showColor Navy = "navy" showColor Orange = "orange" showColor Pink = "pink" showColor Purple = "purple" showColor Red = "red" showColor Tomato = "tomato" showColor Turquoise = "turquoise" showColor Violet = "violet" showColor White = "white" showColor Yellow = "yellow" ------------------------------------------------------------------------ -- Some useful abbreviations: ------------------------------------------------------------------------ --- Horizontal alignment of widgets. row :: [Widget] -> Widget row = Row [] --- Vertical alignment of widgets. col :: [Widget] -> Widget col = Col [] --- Matrix alignment of widgets. matrix :: [[Widget]] -> Widget matrix = Matrix [] ------------------------------------------------------------------------ -- internal translation functions from GUI terms into Tcl: ------------------------------------------------------------------------ -- An event handler specification consists of an identifying string of -- the widget for which this handler is repsonsible, an event type -- to which the handler should react, and a handler: type EventHandler = (String,Event,GuiPort -> IO [ReconfigureItem]) -- translate a widget into a pair of Tcl command string / event list -- argument 1: port for the GUI -- argument 2: current label prefix -- argument 3: the widget to translate -- result: pair of (Tcl command string, -- list of (eventname, eventtype, eventhandler)) widget2tcl :: String -> Widget -> (String,[EventHandler]) widget2tcl label (PlainButton confs) = ("button "++label++"\n" ++ label++" configure -textvariable "++refname++"\n" ++ "proc getvar"++refname++" {} { global "++refname++" ; return $" ++refname++" }\n" ++ "proc setvar"++refname++" {s} { global "++refname++" ; set " ++refname++" $s}\n" ++ conf_tcl , conf_evs) where refname = wLabel2Refname label (conf_tcl,conf_evs) = configs2tcl "button" label confs widget2tcl label (Canvas confs) = ("canvas "++label++"\n" ++"set "++refname++"_scrollx 100\n" ++"set "++refname++"_scrolly 100\n" ++"proc set"++refname++"_scrollx {x}" ++" { global "++refname++"_scrollx ; global "++refname++"_scrolly ;\n" ++" if {$"++refname++"_scrollx < $x} {set "++refname++"_scrollx $x ;\n" ++" "++label++" configure -scrollregion [list 0 0 $" ++refname++"_scrollx $"++refname++"_scrolly]}}\n" ++"proc set"++refname++"_scrolly {y}" ++" { global "++refname++"_scrollx ; global "++refname++"_scrolly ;\n" ++" if {$"++refname++"_scrolly < $y} {set "++refname++"_scrolly $y ;\n" ++" "++label++" configure -scrollregion [list 0 0 $" ++refname++"_scrollx $"++refname++"_scrolly]}}\n" ++ conf_tcl , conf_evs) where refname = wLabel2Refname label (conf_tcl,conf_evs) = configs2tcl "canvas" label confs widget2tcl label (CheckButton confs) = ("checkbutton "++label++"\n" ++ label++" configure -variable "++refname++"\n" ++ "proc getvar"++refname++" {} { global "++refname++" ; return $" ++refname++" }\n" ++ "proc setvar"++refname++" {s} { global "++refname++" ; set " ++refname++" $s}\n" ++ conf_tcl , conf_evs) where refname = wLabel2Refname label (conf_tcl,conf_evs) = configs2tcl "checkbutton" label confs widget2tcl label (Entry confs) = case configs2tcl "entry" label confs of (conf_tcl,conf_evs) -> ("entry "++label++"\n" ++ label++" configure -textvariable "++refname++"\n" ++ "proc getvar"++refname++" {} { global "++refname++" ; return $" ++refname++" }\n" ++ "proc setvar"++refname++" {s} { global "++refname++" ; set " ++refname++" $s}\n" ++ conf_tcl , conf_evs) where refname = wLabel2Refname label widget2tcl label (Label confs) = ("label "++label++"\n" ++ label++" configure -textvariable "++refname++"\n" ++ "proc getvar"++refname++" {} { global "++refname++" ; return $" ++refname++" }\n" ++ "proc setvar"++refname++" {s} { global "++refname++" ; set " ++refname++" $s}\n" ++ conf_tcl , conf_evs) where refname = wLabel2Refname label (conf_tcl,conf_evs) = configs2tcl "label" label confs widget2tcl label (ListBox confs) = ("listbox "++label++" -exportselection false\n" ++ "proc getvar"++refname++" {} { return ["++label++" curselection]}\n" ++ "proc setvar"++refname++" {s} { "++label++" selection clear 0 end ; " ++label++" selection set $s ; "++label++" see $s}\n" ++ conf_tcl , conf_evs) where refname = wLabel2Refname label (conf_tcl,conf_evs) = configs2tcl "listbox" label confs widget2tcl label (Message confs) = ("message "++label++"\n" ++ label++" configure -textvariable "++refname++"\n" ++ "proc getvar"++refname++" {} { global "++refname++" ; return $" ++refname++" }\n" ++ "proc setvar"++refname++" {s} { global "++refname++" ; set " ++refname++" $s}\n" ++ conf_tcl , conf_evs) where refname = wLabel2Refname label (conf_tcl,conf_evs) = configs2tcl "message" label confs widget2tcl label (MenuButton confs) = ("menubutton "++label++"\n" ++ label++" configure -textvariable "++refname++"\n" ++ "proc getvar"++refname++" {} { global "++refname++" ; return $" ++refname++" }\n" ++ "proc setvar"++refname++" {s} { global "++refname++" ; set " ++refname++" $s}\n" ++ conf_tcl , conf_evs) where refname = wLabel2Refname label (conf_tcl,conf_evs) = configs2tcl "menubutton" label confs widget2tcl label (Scale from to confs) = ("scale "++label++" -from "++show from++" -to "++show to++ " -orient horizontal -length 200\n" ++ "variable "++refname++" "++show from++"\n"++ -- initialize scale variable label++" configure -variable "++refname++"\n" ++ "proc getvar"++refname++" {} { global "++refname++" ; return $" ++refname++" }\n" ++ "proc setvar"++refname++" {s} { global "++refname++" ; set " ++refname++" $s}\n" ++ conf_tcl , conf_evs) where refname = wLabel2Refname label (conf_tcl,conf_evs) = configs2tcl "scale" label confs widget2tcl label (ScrollH widget confs) = ("scrollbar "++label++" -orient horizontal -command {"++ wRef2Label widget++" xview}\n" ++ wRef2Label widget++" configure -xscrollcommand {"++label++" set}\n" ++ conf_tcl , conf_evs) where (conf_tcl,conf_evs) = configs2tcl "scrollbar" label confs widget2tcl label (ScrollV widget confs) = ("scrollbar "++label++" -command {"++wRef2Label widget++" yview}\n" ++ wRef2Label widget++" configure -yscrollcommand {"++label++" set}\n" ++ conf_tcl , conf_evs) where (conf_tcl,conf_evs) = configs2tcl "scrollbar" label confs widget2tcl label (TextEdit confs) = ("text "++label++"\n"++ --" -height 15\n" ++ "proc getvar"++refname++" {} { "++label++" get 1.0 {end -1 chars}}\n" ++ "proc setvar"++refname++" {s} { "++label++" delete 1.0 end ; " ++label++" insert 1.0 $s}\n" ++ conf_tcl ++ enableFont "italic" "-slant italic" ++ enableFont "underline" "-underline on" ++ enableFont "bold" "-weight bold" ++ unlines (map enableForeground colors) ++ unlines (map enableBackground colors) , conf_evs) where refname = wLabel2Refname label (conf_tcl,conf_evs) = configs2tcl "textedit" label confs enableFont tag style = label ++ " tag configure " ++ tag ++ " -font \"[font actual [" ++ label ++ " cget -font]] " ++ style ++ "\"\n" colors = map showColor [Black,Blue,Brown,Cyan,Gold,Gray,Green,Magenta,Navy,Orange,Pink ,Purple,Red,Tomato,Turquoise,Violet,White,Yellow] enableForeground color = label ++ " tag configure " ++ dropSpaces color ++ " -foreground \"" ++ color ++ "\"" enableBackground color = label++" tag configure "++ camelCase color ++ " -background \"" ++ color ++ "\"" widget2tcl label (Row confs ws) = case widgets2tcl label 97 ws of (wstcl,wsevs) -> ((if label=="" then "wm resizable . " ++ resizeBehavior wsGridInfo++"\n" else "frame "++label++"\n") ++ wstcl ++ (snd $ foldl (\ (n,g) l->(n+1,g++"grid "++label++labelIndex2string (96+n) ++" -row 1 -column "++show n++" " ++confCollection2tcl confs ++gridInfo2tcl n label "col" l ++ "\n")) (1,"") wsGridInfo), wsevs) where wsGridInfo = widgets2gridinfo ws widget2tcl label (Col confs ws) = case widgets2tcl label 97 ws of (wstcl,wsevs) -> ((if label=="" then "wm resizable . " ++ resizeBehavior wsGridInfo++"\n" else "frame "++label++"\n") ++ wstcl ++ (snd $ foldl (\ (n,g) l->(n+1,g++"grid "++label ++labelIndex2string (96+n) ++" -column 1 -row "++show n++" " ++confCollection2tcl confs ++gridInfo2tcl n label "row" l ++ "\n")) (1,"") (widgets2gridinfo ws)), wsevs) where wsGridInfo = widgets2gridinfo ws widget2tcl label (Matrix confs ws) = ((if label == "" then "wm resizable . " ++ resizeBehavior wsGridInfo++"\n" else "frame "++label++"\n") ++ wstcl,wsevs) where (wstcl,wsevs) = matrix2tcl 97 1 label confs ws wsGridInfo = concatMap widgets2gridinfo ws -- actual translation function of the list of lists of widgets in a matrix matrix2tcl :: Int -> Int -> String -> [ConfCollection] -> [[Widget]] -> (String,[EventHandler]) matrix2tcl _ _ _ _ [] = ("",[]) matrix2tcl nextLabel n label confs (ws:wss) = (wstcl ++ (snd $ foldl (\ (m,g) l->(m+1,g++"grid "++label ++labelIndex2string (nextLabel+m-1) ++" -row "++show n ++" -column "++show m++" " ++confCollection2tcl confs ++gridInfo2tcl m label "col" l ++ "\n")) (1,"") wsGridInfo) ++ wsstcl, wsevs++wssevs) where (wsstcl,wssevs) = matrix2tcl (nextLabel+length ws) (n+1) label confs wss (wstcl,wsevs) = widgets2tcl label nextLabel ws wsGridInfo = widgets2gridinfo ws -- compute the required resize behavior of the top window resizeBehavior :: [[ConfItem]] -> String resizeBehavior ws = if any (any isFill) ws then "1 1" else if any (any isFillX) ws then "1 0" else if any (any isFillY) ws then "0 1" else "0 0" -- list of labels of the widgets widgets2gridinfo [] = [] widgets2gridinfo (w:ws) = (tclfill ++ getConfs w): widgets2gridinfo ws where fillx = hasFillX w filly = hasFillY w flexible = hasFill w tclfill = if flexible || (fillx && filly) then [Fill] else if fillx then [FillX] else if filly then [FillY] else [] hasFillX w = any isFillX (propagateFillInfo w) hasFillY w = any isFillY (propagateFillInfo w) hasFill w = any isFill (propagateFillInfo w) isFillInfo conf = case conf of FillX -> True FillY -> True Fill -> True _ -> False -- propagate FillInfo for those kinds of widgets which are resizable on their on propagateFillInfo (PlainButton _) = [] propagateFillInfo (Canvas confs) = filter isFillInfo confs propagateFillInfo (CheckButton _) = [] propagateFillInfo (Entry confs) = filter isFillInfo confs propagateFillInfo (Label confs) = filter isFillInfo confs propagateFillInfo (ListBox confs) = filter isFillInfo confs propagateFillInfo (Message confs) = filter isFillInfo confs propagateFillInfo (MenuButton _) = [] propagateFillInfo (Scale _ _ confs) = filter isFillInfo confs propagateFillInfo (ScrollV _ _) = [] propagateFillInfo (ScrollH _ _) = [] propagateFillInfo (TextEdit confs) = filter isFillInfo confs propagateFillInfo (Row _ ws) = concatMap propagateFillInfo ws propagateFillInfo (Col _ ws) = concatMap propagateFillInfo ws propagateFillInfo (Matrix _ wss) = concatMap (concatMap propagateFillInfo) wss -- get the configurations of a widget getConfs (PlainButton confs) = confs getConfs (Canvas confs) = filter isFillInfo confs getConfs (CheckButton confs) = confs getConfs (Entry confs) = filter isFillInfo confs getConfs (Label confs) = filter isFillInfo confs getConfs (ListBox confs) = filter isFillInfo confs getConfs (Message confs) = filter isFillInfo confs getConfs (MenuButton confs) = confs getConfs (Scale _ _ confs) = filter isFillInfo confs getConfs (ScrollV _ confs) = confs getConfs (ScrollH _ confs) = confs getConfs (TextEdit confs) = filter isFillInfo confs getConfs (Row _ _) = [] getConfs (Col _ _) = [] getConfs (Matrix _ _) = [] -- translate configuration options for collections (rows or columns) -- into parameters for the Tcl/Tk command "grid": confCollection2tcl [] = "" confCollection2tcl (CenterAlign : confs) = confCollection2tcl confs confCollection2tcl (LeftAlign : confs) = "-sticky w " ++ confCollection2tcl confs confCollection2tcl (RightAlign : confs) = "-sticky e " ++ confCollection2tcl confs confCollection2tcl (TopAlign : confs) = "-sticky n " ++ confCollection2tcl confs confCollection2tcl (BottomAlign : confs) = "-sticky s " ++ confCollection2tcl confs -- translate the Fill - options to sticky options and grid configures gridInfo2tcl :: Int -> String -> String -> [ConfItem] -> String gridInfo2tcl n label "col" confs | any isFill confs || (any isFillX confs && any isFillY confs) = "-sticky nsew \ngrid columnconfigure "++lab++" "++show n++ " -weight 1\ngrid rowconfigure "++lab++" 1 -weight 1" | any isFillX confs = "-sticky we \ngrid columnconfigure "++lab++ " "++show n++" -weight 1" | any isFillY confs = "-sticky ns \ngrid rowconfigure "++lab++ " 1 -weight 1" | otherwise = "" where lab = if label=="" then "." else label gridInfo2tcl n label "row" confs | any isFill confs || (any isFillX confs && any isFillY confs) = "-sticky nsew \ngrid columnconfigure "++lab++ " 1 -weight 1\ngrid rowconfigure "++lab++" "++show n++" -weight 1" | any isFillX confs = "-sticky we \ngrid columnconfigure "++lab++ " 1 -weight 1" | any isFillY confs = "-sticky ns \ngrid rowconfigure "++lab++ " "++show n++" -weight 1" | otherwise = "" where lab = if label=="" then "." else label -- translate a single configuration option into Tcl/Tk commands -- to configure the widget: -- the first argument specifies the type of the widget -- (button/canvas/checkbutton/entry/label/listbox/message/scale/scrollbar/ -- textedit) -- and the third argument is the widget label config2tcl :: String -> String -> ConfItem -> String -- is the state of the widget active ("normal" in Tcl/Tk) or -- inactive ("disabled" in Tcl/Tk)? -- (inactive widgets do not accept any events) config2tcl wtype label (Active active) = if wtype=="button" || wtype=="checkbutton" || wtype=="entry" || wtype=="menubutton" || wtype=="scale" || wtype=="textedit" then if active then label++" configure -state normal\n" else label++" configure -state disabled\n" else trace ("WARNING: GUI.Active ignored for widget type \""++wtype++"\"\n") "" -- alignment of information inside a widget -- argument must be: n, ne, e, se, s, sw, w, nw, or center config2tcl wtype label (Anchor align) = if wtype=="button" || wtype=="checkbutton" || wtype=="label" || wtype=="menubutton" || wtype=="message" then label++" configure -anchor "++align++"\n" else trace ("WARNING: GUI.Anchor ignored for widget type \""++wtype++"\"\n") "" -- background color: config2tcl _ label (Background color) = label++" configure -background \""++color++"\"\n" -- foreground color: config2tcl _ label (Foreground color) = label++" configure -foreground \""++color++"\"\n" -- command associated to various widgets: config2tcl wtype label (Handler evtype _) | evtype == DefaultEvent = if wtype=="button" then label++" configure -command"++writeEvent else if wtype=="checkbutton" then label++" configure -command"++writeEvent else if wtype=="entry" then "bind "++label++" "++writeEvent else if wtype=="scale" then label++" configure -command { putlabel \""++label++event2tcl evtype++"\"}\n" else if wtype=="listbox" then "bind "++label++" "++writeEvent else if wtype=="textedit" then "bind "++label++" "++writeEvent else trace ("WARNING: GUI.Handler with DefaultEvent ignored for widget type \""++ wtype++"\"\n") "" | otherwise = "bind "++label++event2tcl evtype++writeEvent where writeEvent = " { writeevent \""++label++event2tcl evtype++"\" }\n" -- height of a widget (not defined for all widget types): config2tcl wtype label (Height h) | wtype=="entry" || wtype=="message" || wtype=="menubutton" || wtype=="scale" = trace ("WARNING: GUI.Height ignored for widget type \""++wtype++"\"\n") "" | wtype=="canvas" = label++" configure -height "++show h++"\n"++ "set"++wLabel2Refname label++"_scrolly "++show h++"\n" | otherwise = label++" configure -height "++show h++"\n" -- value of checkbuttons: config2tcl wtype label (CheckInit s) | wtype=="checkbutton" = "setvar"++wLabel2Refname label++" \""++s++"\"\n" | otherwise = trace ("WARNING: GUI.CheckInit ignored for widget type \""++wtype++"\"\n") "" -- items in a canvas: config2tcl wtype label (CanvasItems items) | wtype=="canvas" = canvasItems2tcl label items | otherwise = trace ("WARNING: GUI.CanvasItems ignored for widget type \""++wtype++"\"\n") "" -- value lists for listboxes: config2tcl wtype label (List l) | wtype=="listbox" = label++" delete 0 end\n" ++ setlistelems (ensureSpine l) | otherwise = trace ("WARNING: GUI.List ignored for widget type \""++wtype++"\"\n") "" where setlistelems [] = "" setlistelems (e:es) = label++" insert end \""++escapeTcl e++"\"\n"++ setlistelems es -- items in a menu button: config2tcl wtype label (Menu l) | wtype=="menubutton" = label++" configure -menu "++label++".a\n" ++ menu2tcl (label++".a") l | otherwise = trace ("WARNING: GUI.Menu ignored for widget type \""++wtype++"\"\n") "" -- references to widgets are bound to actual widget labels: config2tcl wtype label (WRef r) | r =:= WRefLabel (wLabel2Refname label) wtype = "" -- initial text value of widgets: config2tcl wtype label (Text s) | wtype=="canvas" = trace "WARNING: GUI.Text ignored for Canvas\n" "" | wtype=="checkbutton" = label++" configure -text \""++escapeTcl s++"\"\n" | otherwise = "setvar"++wLabel2Refname label++" \""++escapeTcl s++"\"\n" -- width of a widget: config2tcl wtype label (Width w) | wtype=="canvas" = label++" configure -width "++show w++"\n"++ "set"++wLabel2Refname label++"_scrollx "++show w++"\n" | otherwise = label++" configure -width "++show w++"\n" -- configuration options for widget composition are ignored here -- since they are used during geometry management config2tcl _ _ Fill = "" config2tcl _ _ FillX = "" config2tcl _ _ FillY = "" -- for testing, put arbitrary Tk options for this widget: config2tcl _ label (TclOption tcloptions) = label++" configure "++tcloptions++"\n" -- translation of a menu with a given label: menu2tcl label menu = "menu "++label++" -tearoff false\n" ++ label++" delete 0 end\n" ++ setmenuelems menu 0 where setmenuelems [] _ = "" setmenuelems (MButton _ text : es) i = label++" add command -label \""++escapeTcl text++ "\" -command { writeevent \""++label++"."++show i++ event2tcl DefaultEvent++"\" }\n"++ setmenuelems es (i+1) setmenuelems (MSeparator : es) i = label++" add separator\n"++ setmenuelems es (i+1) setmenuelems (MMenuButton text l : es) i = label++" add cascade -label \""++escapeTcl text++ "\" -menu "++label++labelIndex2string (i+97)++"\n"++ menu2tcl (label++labelIndex2string (i+97)) l ++ setmenuelems es (i+1) -- get the event handlers in a list of configuration options: -- and bind widget references: configs2handler :: String -> [ConfItem] -> [EventHandler] configs2handler _ [] = [] configs2handler label (confitem : cs) = case confitem of Handler evtype handler -> (label,evtype,handler) : configs2handler label cs Menu m -> menu2handler (label++".a") m 0 ++ configs2handler label cs _ -> configs2handler label cs menu2handler _ [] _ = [] menu2handler label (MButton handler _ : ms) i = (label++"."++show i, DefaultEvent, handler) : menu2handler label ms (i+1) menu2handler label (MSeparator : ms) i = menu2handler label ms (i+1) menu2handler label (MMenuButton _ menu : ms) i = menu2handler (label++labelIndex2string (i+97)) menu 0 ++ menu2handler label ms (i+1) -- translate configuration options into Tcl/Tk commands and event handler map: configs2tcl :: String -> String -> [ConfItem] -> (String,[EventHandler]) configs2tcl wtype label confs = (concatMap (config2tcl wtype label) confs, configs2handler label confs) -- translate a list of canvas items into a Tcl string: canvasItems2tcl _ [] = "" canvasItems2tcl label (i:is) = canvasItem2tcl label i ++ canvasItems2tcl label is canvasItem2tcl label (CLine coords opts) = label++ " create line "++showCoords coords++" "++opts++"\n"++ concatMap (\(x,_)->"set"++refname++"_scrollx "++show x++"\n") coords ++ concatMap (\(_,y)->"set"++refname++"_scrolly "++show y++"\n") coords where refname = wLabel2Refname label canvasItem2tcl label (CPolygon coords opts) = label++ " create polygon "++showCoords coords++" "++opts++"\n"++ concatMap (\(x,_)->"set"++refname++"_scrollx "++show x++"\n") coords ++ concatMap (\(_,y)->"set"++refname++"_scrolly "++show y++"\n") coords where refname = wLabel2Refname label canvasItem2tcl label (CRectangle (x1,y1) (x2,y2) opts) = label++ " create rectangle "++showCoords [(x1,y1),(x2,y2)]++" "++opts++"\n"++ concatMap (\x->"set"++refname++"_scrollx "++show x++"\n") [x1,x2] ++ concatMap (\y->"set"++refname++"_scrolly "++show y++"\n") [y1,y2] where refname = wLabel2Refname label canvasItem2tcl label (COval (x1,y1) (x2,y2) opts) = label++ " create oval "++showCoords [(x1,y1),(x2,y2)]++" "++opts++"\n"++ concatMap (\x->"set"++refname++"_scrollx "++show x++"\n") [x1,x2] ++ concatMap (\y->"set"++refname++"_scrolly "++show y++"\n") [y1,y2] where refname = wLabel2Refname label canvasItem2tcl label (CText (x,y) text opts) = label++ " create text "++show x++" "++show y++ " -text \""++escapeTcl text++"\" "++opts++"\n"++ "set"++refname++"_scrollx "++show (x+5*(length text))++"\n"++ "set"++refname++"_scrolly "++show y++"\n" where refname = wLabel2Refname label showCoords [] = "" showCoords ((x,y):cs) = show x++" "++show y++" "++showCoords cs -- translate a widget label into a name (replacing dots by underscores) wLabel2Refname l = map (\c -> if c=='.' then '_' else c) l -- translate a name into a widget label (replacing underscores by dots) wRefname2Label l = map (\c -> if c=='_' then '.' else c) l -- translate a list of widgets into pair Tcl string / event list: widgets2tcl _ _ [] = ("",[]) widgets2tcl lab nr (w:ws) = case widget2tcl (lab++labelIndex2string nr) w of (wtcl,wevs) -> case widgets2tcl lab (nr+1) ws of (wstcl,wsevs) -> (wtcl ++ wstcl, wevs ++ wsevs) -- translate a label index into a textual label -- (e.g., 97->".a" or 123->".z1"): labelIndex2string :: Int -> String labelIndex2string li = if li<123 then ['.',chr li] else ['.','z'] ++ show (li-122) -- translate main widget: mainWidget2tcl :: Widget -> (String,[EventHandler]) mainWidget2tcl widget = ("proc writeevent {l} { puts \":EVT$l\" }\n" ++ "proc putlabel {l v} { writeevent $l }\n" ++ "proc putvar {var value} { puts \":VAR$var%[string length $value]*$value\"}\n" ++ widgettcl, evs) where (widgettcl,evs) = widget2tcl "" widget --- Prints the generated Tcl commands of a main widget (useful for debugging). debugTcl :: Widget -> IO () debugTcl widget = putStrLn (fst (mainWidget2tcl widget)) ------------------------------------------------------------------------ -- Operations to communicate with Tcl/Tk: ------------------------------------------------------------------------ reportTclTk s = if showTclTkCommunication then hPutStrLn stdout s else done reportTclTkError s = if showTclTkErrors then hPutStrLn stderr s else done -- Open a GUI port by connecting to new "wish" process. -- The first argument are parameters passed to the wish command. openGuiPort :: String -> IO GuiPort openGuiPort wishparams = do exwish <- system "which wish > /dev/null" when (exwish>0) $ error "Windowing shell `wish' not found. Please install package `tk'!" reportTclTk ("OPEN CONNECTION TO WISH WITH PARAMS: "++wishparams) tclhdl <- connectToCommand ("wish "++wishparams) return (GuiPort tclhdl) -- Send a string (Tcl/Tk command) to GUI port: send2tk :: String -> GuiPort -> IO () send2tk s (GuiPort tclhdl) = do reportTclTk ("GUI SEND: "++s) hPutStrLn tclhdl s hFlush tclhdl -- Receive an output line from the wish process: receiveFromTk :: GuiPort -> IO String receiveFromTk (GuiPort tclhdl) = do s <- hGetLine tclhdl reportTclTk ("GUI RECEIVED: "++s) return s -- Choice over the output of the wish process and handles to input streams: choiceOverHandles :: [Handle] -> IO (Int,Handle) choiceOverHandles hdls = do i <- hWaitForInputs hdls (-1) return (i,hdls!!i) -- Close connection to wish process: closeGuiPort :: GuiPort -> IO () closeGuiPort (GuiPort tclhdl) = do reportTclTk "CLOSE CONNECTION TO WISH" hClose tclhdl ------------------------------------------------------------------------ -- functions for running a GUI: ------------------------------------------------------------------------ --- Creates a new GUI window with a "title" for the top-level window --- (but unspecified contents). A GUI port is returned that can be --- used to start a GUI specification on this port. --- @param title - the title of the top-level window --- @param params - parameter string passed to the initial wish command openWish :: String -> String -> IO GuiPort openWish title params = do gport <- openGuiPort params send2tk ("wm title . \""++title++"\"\n") gport return gport --- IO action to show a Widget in a new GUI window in passive mode, --- i.e., ignore all GUI events. --- @param title - the title of the main window containing the widget --- @param widget - the widget shown in the new window runPassiveGUI :: String -> Widget -> IO GuiPort runPassiveGUI title widget = do gport <- openWish (escapeTcl title) "" send2tk (fst (mainWidget2tcl widget)) gport return gport --- IO action to run a Widget in a new window. --- @param title - the title of the main window containing the widget --- @param widget - the widget shown in the new window runGUI :: String -> Widget -> IO () runGUI title widget = runInitGUIwithParams title "" widget (const (return [])) --- IO action to run a Widget in a new window. --- @param title - the title of the main window containing the widget --- @param params - parameter string passed to the initial wish command --- @param widget - the widget shown in the new window runGUIwithParams :: String -> String -> Widget -> IO () runGUIwithParams title params widget = runInitGUIwithParams title params widget (const (return [])) --- IO action to run a Widget in a new window. The GUI events --- are processed after executing an initial action on the GUI. --- @param title - the title of the main GUI window --- @param widget - the widget shown in the new GUI window --- @param initcmd - the initial command executed before activating the GUI runInitGUI :: String -> Widget -> (GuiPort -> IO [ReconfigureItem]) -> IO () runInitGUI title widget initcmd = do gport <- openWish (escapeTcl title) "" initSchedule widget gport [] initcmd --- IO action to run a Widget in a new window. The GUI events --- are processed after executing an initial action on the GUI. --- @param title - the title of the main GUI window --- @param params - parameter string passed to the initial wish command --- @param widget - the widget shown in the new GUI window --- @param initcmd - the initial command executed before activating the GUI runInitGUIwithParams :: String -> String -> Widget -> (GuiPort -> IO [ReconfigureItem]) -> IO () runInitGUIwithParams title params widget initcmd = do gport <- openWish (escapeTcl title) params initSchedule widget gport [] initcmd --- Runs a Widget in a new GUI window and process GUI events. --- In addition, an event handler is provided that process --- messages received from an external stream identified by a handle --- (third argument). --- This operation is useful to run a GUI that should react on --- user events as well as messages written to the given handle. --- @param title - the title of the main window containing the widget --- @param th - a pair (widget,exth) where widget is the widget shown in the --- new window and exth is the event handler for external messages --- @param hdl - the handle of the stream of external messages runControlledGUI :: String -> (Widget, String -> GuiPort -> IO ()) -> Handle -> IO () runControlledGUI title (widget,exth) hdl = runInitControlledGUI title (widget,exth) (\_->return []) hdl --- Runs a Widget in a new GUI window and process GUI events. --- In addition, an event handler is provided that process --- messages received from an external stream identified by a handle --- (third argument). --- This operation is useful to run a GUI that should react on --- user events as well as messages written to the given handle. --- @param title - the title of the main window containing the widget --- @param th - a pair (widget,exth) where widget is the widget shown in the --- new window and exth is the event handler for external messages --- that returns a list of widget reference/configuration pairs --- which is applied after the handler in order to configure --- some GUI widgets --- @param hdl - the handle of the stream of external messages runConfigControlledGUI :: String -> (Widget, String -> GuiPort -> IO [ReconfigureItem]) -> Handle -> IO () runConfigControlledGUI title (widget,exth) hdl = do gport <- openWish (escapeTcl title) "" initSchedule widget gport [msgToIOHandler exth hdl] (\_->return []) --- Runs a Widget in a new GUI window and process GUI events --- after executing an initial action on the GUI window. --- In addition, an event handler is provided that process --- messages received from an external message stream. --- This operation is useful to run a GUI that should react on --- user events as well as messages written to the given handle. --- @param title - the title of the main window containing the widget --- @param th - a pair (widget,exth) where widget is the widget shown in the --- new window and exth is the event handler for external messages --- @param initcmd - the initial command executed before starting the GUI --- @param hdl - the handle of the stream of external messages runInitControlledGUI :: String -> (Widget, String -> GuiPort -> IO ()) -> (GuiPort -> IO [ReconfigureItem]) -> Handle -> IO () runInitControlledGUI title (widget,exth) initcmd hdl = do gport <- openWish (escapeTcl title) "" initSchedule widget gport [msgToIOHandler (\ x y -> exth x y >> return []) hdl] initcmd msgToIOHandler :: (String -> GuiPort -> IO [ReconfigureItem]) -> Handle -> ExternalHandler msgToIOHandler hdler hdl = IOHandler (hdl,\ _ hd gp -> do l <- hGetLine hd cfs <- hdler l gp return (Just cfs)) --- Runs a Widget in a new GUI window and process GUI events. --- In addition, a list of event handlers is provided that process --- inputs received from a corresponding list of handles to input streams. --- Thus, if the i-th handle has some data available, the i-th event handler --- is executed with the i-th handle as a parameter. --- This operation is useful to run a GUI that should react on --- inputs provided by other processes, e.g., via sockets. --- @param title - the title of the main window containing the widget --- @param th - a pair (widget,handlers) where widget is the widget shown in the --- new window and handlers is a list of event handler for external inputs --- @param handles - a list of handles to the external input streams for the --- corresponding event handlers runHandlesControlledGUI :: String -> (Widget,[Handle -> GuiPort -> IO [ReconfigureItem]]) -> [Handle] -> IO () runHandlesControlledGUI title widgethandlers handles = runInitHandlesControlledGUI title widgethandlers (\_->return []) handles --- Runs a Widget in a new GUI window and process GUI events --- after executing an initial action on the GUI window. --- In addition, a list of event handlers is provided that process --- inputs received from a corresponding list of handles to input streams. --- Thus, if the i-th handle has some data available, the i-th event handler --- is executed with the i-th handle as a parameter. --- This operation is useful to run a GUI that should react on --- inputs provided by other processes, e.g., via sockets. --- @param title - the title of the main window containing the widget --- @param th - a pair (widget,handlers) where widget is the widget shown in the --- new window and handlers is a list of event handler for external inputs --- @param initcmd - the initial command executed before starting the GUI --- @param handles - a list of handles to the external input streams for the --- corresponding event handlers runInitHandlesControlledGUI :: String -> (Widget,[Handle -> GuiPort -> IO [ReconfigureItem]]) -> (GuiPort -> IO [ReconfigureItem]) -> [Handle] -> IO () runInitHandlesControlledGUI title (widget,handlers) initcmd handles = do gport <- openWish (escapeTcl title) "" initSchedule widget gport (map IOHandler (zip handles (map toIOHandler handlers))) initcmd -- The type of external event handlers currently supported. -- It is either a handler processing messages from an external port -- or a handler processing input from various IO streams data ExternalHandler = IOHandler (Handle, [EventHandler] -> Handle -> GuiPort -> IO (Maybe [ReconfigureItem])) -- start the scheduler (see below) with a given Widget on a wish port -- and an initial command: initSchedule :: Widget -> GuiPort -> [ExternalHandler] -> (GuiPort -> IO [ReconfigureItem]) -> IO () initSchedule widget gport exths initcmd = do send2tk tcl gport confs <- initcmd gport -- add handler on wish connection as first handler: configAndProceedScheduler evs gport (IOHandler (handleOf gport,processTkEvent) : exths) (Just confs) where (tcl,evs) = mainWidget2tcl widget -- Scheduler for Tcl/Tk events: -- -- Meaning of arguments: -- evs: list of EventHandlers -- gport: port to a wish -- exth: handler for external messages -- msgs: list of external messages scheduleTkEvents :: [EventHandler] -> GuiPort -> [ExternalHandler] -> IO () -- schedule GUI with handler for external port: scheduleTkEvents evs gport exthds = do (i,hdl) <- choiceOverHandles (map fst iohandlers) if i<0 then done else snd (iohandlers!!i) evs hdl gport >>= configAndProceedScheduler evs gport exthds where iohandlers = map (\ (IOHandler x) -> x) exthds -- process an event from the wish and return the new configuration items: processTkEvent :: [EventHandler] -> Handle -> GuiPort -> IO (Maybe [ReconfigureItem]) processTkEvent evs str gport = hIsEOF str >>= \eof -> if eof then return Nothing -- connection closed (by wish) else do ans <- hGetLine str reportTclTk ("GUI RECEIVED: "++ans) if (take 4 ans)==":EVT" then do let (evwidget,evtype) = break (==' ') (drop 4 ans) configs <- selectEvent evwidget evtype evs gport return (Just configs) else do reportTclTkError("ERROR in scheduleTkEvents: Received: "++ans++"\n") -- ignore other outputs: return (Just []) -- Reconfigure scheduler with new configurations and proceed. -- If the configs are Nothing, then terminate the scheduler -- (this case occurs of the connection is closed by wish) configAndProceedScheduler :: [(String,Event,GuiPort -> IO [ReconfigureItem])] -> GuiPort -> [ExternalHandler] -> Maybe [ReconfigureItem] -> IO () configAndProceedScheduler _ gport _ Nothing = closeGuiPort gport configAndProceedScheduler evs gport exths (Just configs) = do mapIO_ reconfigureGUI configs scheduleTkEvents (configEventHandlers evs configs) gport (configStreamHandlers exths configs) where reconfigureGUI (WidgetConf r ci) = setConfig r ci gport reconfigureGUI (StreamHandler _ _) = done reconfigureGUI (RemoveStreamHandler _) = done configEventHandlers evs [] = evs configEventHandlers evs (WidgetConf ref confitem : confitems) = let label = wRef2Label ref in case confitem of Handler evtype handler -> configEventHandlers ((label,evtype,handler) : (filter (\ (l,t,_)->l/=label || t/=evtype) evs)) confitems _ -> configEventHandlers evs confitems configEventHandlers evs (StreamHandler _ _ : confitems) = configEventHandlers evs confitems configEventHandlers evs (RemoveStreamHandler _ : confitems) = configEventHandlers evs confitems -- reconfigure external stream handlers: configStreamHandlers exths [] = exths configStreamHandlers exths (WidgetConf _ _ : confitems) = configStreamHandlers exths confitems configStreamHandlers exths (StreamHandler handle handler : confitems) = configStreamHandlers (exths++[IOHandler (handle,\_ hdl gp -> handler hdl gp >>= return . Just)]) confitems configStreamHandlers exths (RemoveStreamHandler handle : confitems) = configStreamHandlers (removeHandler handle exths) confitems where removeHandler _ [] = [] removeHandler h (IOHandler (h',hr) : ehs) = if h==h' then removeHandler h ehs else IOHandler (h',hr) : removeHandler h ehs -- transform external handler into an IO Handler used in the scheduler -- which always returns empty configurations: toIOHandler handler _ handle gport = handler handle gport >>= return . Just --- Changes the current configuration of a widget --- (deprecated operation, only included for backward compatibility). --- Warning: does not work for Command options! setConfig :: WidgetRef -> ConfItem -> GuiPort -> IO () setConfig (WRefLabel var wtype) confitem gport = send2tk (config2tcl wtype (wRefname2Label var) confitem) gport selectEvent evwidget evtype [] _ = trace ("Internal error in GUI.curry: no handler for event: "++ evwidget++evtype++"\n") (return []) selectEvent evwidget evtype ((ev,hevtype,handler):evs) gport = if evwidget==ev && event2tcl hevtype == evtype then handler gport else selectEvent evwidget evtype evs gport -- get the current value of a widget " by -- 1. executing the Tcl procedure "putvar [getvar_]" -- 2. reading the message ":VAR%* -- (where is the length of which can be more than one line) getWidgetVar :: String -> GuiPort -> IO String getWidgetVar var gport = do send2tk ("putvar "++var++" [getvar"++var++"]") gport getWidgetVarMsg var gport getWidgetVarMsg var gport = receiveFromTk gport >>= \varmsg -> if takeWhile (/='%') varmsg == ":VAR"++var then let (len,value) = break (=='*') (tail (dropWhile (/='%') varmsg)) in getWidgetVarValue (readNat len) (tail value) gport else do reportTclTkError ("ERROR in getWidgetVar \""++var++"\": Received: " ++varmsg++"\n") getWidgetVarMsg var gport -- ignore other messages and try again getWidgetVarValue len valmsg gport = if length valmsg < len then do remvalmsg <- getWidgetVarRemValue (len - (length valmsg + 1)) gport return (valmsg++"\n"++remvalmsg) else do if length valmsg > len then reportTclTkError ("ERROR in getWidgetVar: answer too short\n") else done return valmsg getWidgetVarRemValue len gport = receiveFromTk gport >>= \valmsg -> if length valmsg < len then getWidgetVarRemValue (len - (length valmsg + 1)) gport >>= \remvalmsg -> return (valmsg++"\n"++remvalmsg) else do if length valmsg > len then reportTclTkError ("ERROR in getWidgetVar: answer too short\n") else done return valmsg -- escape some Tcl special characters (brackets, dollars): escapeTcl [] = [] escapeTcl (c:s) = if c=='[' || c==']' || c=='$' || c=='"' || c=='\\' then '\\':c:escapeTcl s else c:escapeTcl s ---------------------------------------------------------------------------- -- Some useful IO actions for implementing event handlers... ---------------------------------------------------------------------------- --- An event handler for terminating the GUI. exitGUI :: GuiPort -> IO () exitGUI gport = send2tk "exit" gport -- this also terminates the scheduler -- due to EOF on the gport handle --- Gets the (String) value of a variable in a GUI. getValue :: WidgetRef -> GuiPort -> IO String getValue (WRefLabel var _) gport = getWidgetVar var gport --- Sets the (String) value of a variable in a GUI. setValue :: WidgetRef -> String -> GuiPort -> IO () setValue (WRefLabel var _) val gport = send2tk ("setvar"++var++" \""++escapeTcl val++"\"") gport --- Updates the (String) value of a variable w.r.t. to an update function. updateValue :: (String->String) -> WidgetRef -> GuiPort -> IO () updateValue upd wref gport = do val <- getValue wref gport setValue wref (upd val) gport --- Appends a String value to the contents of a TextEdit widget and --- adjust the view to the end of the TextEdit widget. appendValue :: WidgetRef -> String -> GuiPort -> IO () appendValue (WRefLabel var wtype) val gport = if wtype/="textedit" then trace ("WARNING: GUI.appendValue ignored for widget type \""++wtype++"\"\n") done else send2tk (wRefname2Label var++" insert end \""++escapeTcl val++"\"") gport >> send2tk (wRefname2Label var++" see end") gport --- Appends a String value with style tags to the contents of a TextEdit widget --- and adjust the view to the end of the TextEdit widget. --- Different styles can be combined, e.g., to get bold blue text on a --- red background. If Bold, Italic and --- Underline are combined, currently all but one of these are --- ignored. --- This is an experimental function and might be changed in the future. appendStyledValue :: WidgetRef -> String -> [Style] -> GuiPort -> IO () appendStyledValue (WRefLabel var wtype) val styles gport = if wtype/="textedit" then trace ("WARNING: GUI.appendStyledValue ignored for widget type \""++wtype++"\"\n") done else send2tk (wRefname2Label var++" insert end \""++escapeTcl val++"\"" ++" \""++showStyles styles++"\"") gport >> send2tk (wRefname2Label var++" see end") gport where showStyles = foldr (\st s -> showStyle st ++ " " ++ s) "" --- Adds a style value in a region of a TextEdit widget. --- The region is specified a start and end position similarly --- to getCursorPosition. --- Different styles can be combined, e.g., to get bold blue text on a --- red background. If Bold, Italic and --- Underline are combined, currently all but one of these are --- ignored. --- This is an experimental function and might be changed in the future. addRegionStyle :: WidgetRef -> (Int,Int) -> (Int,Int) -> Style -> GuiPort -> IO () addRegionStyle (WRefLabel var wtype) (l1,c1) (l2,c2) style gport = if wtype/="textedit" then trace ("WARNING: GUI.setRegionStyle ignored for widget type \""++wtype++"\"\n") done else send2tk (wRefname2Label var++" tag add "++showStyle style++" "++ show l1++"."++show c1++" "++show l2++"."++show c2) gport --- Removes a style value in a region of a TextEdit widget. --- The region is specified a start and end position similarly --- to getCursorPosition. --- This is an experimental function and might be changed in the future. removeRegionStyle :: WidgetRef -> (Int,Int) -> (Int,Int) -> Style -> GuiPort -> IO () removeRegionStyle (WRefLabel var wtype) (l1,c1) (l2,c2) style gport = if wtype/="textedit" then trace ("WARNING: GUI.setRegionStyle ignored for widget type \""++wtype++"\"\n") done else send2tk (wRefname2Label var++" tag remove "++showStyle style++" "++ show l1++"."++show c1++" "++show l2++"."++show c2) gport --- Get the position (line,column) of the insertion cursor in a TextEdit --- widget. Lines are numbered from 1 and columns are numbered from 0. getCursorPosition :: WidgetRef -> GuiPort -> IO (Int,Int) getCursorPosition (WRefLabel var wtype) gport = if wtype/="textedit" then error ("GUI.getCursorPosition not applicable to widget type \""++ wtype++"\"") else do send2tk ("puts [ "++wRefname2Label var++" index insert ]") gport line <- receiveFromTk gport let (ls,ps) = break (=='.') line return (if null ps then (0,0) else (readNat ls, readNat (tail ps))) --- Adjust the view of a TextEdit widget so that the specified line/column --- character is visible. --- Lines are numbered from 1 and columns are numbered from 0. seeText :: WidgetRef -> (Int,Int) -> GuiPort -> IO () seeText (WRefLabel var wtype) (line,column) gport = if wtype/="textedit" then trace ("WARNING: GUI.seeText ignored for widget type \""++wtype++"\"\n") done else send2tk (wRefname2Label var++" see "++show line++"."++show column) gport --- Sets the input focus of this GUI to the widget referred by the first --- argument. --- This is useful for automatically selecting input entries in an application. focusInput :: WidgetRef -> GuiPort -> IO () focusInput (WRefLabel var _) gport = do send2tk ("focus "++wRefname2Label var) gport --- Adds a list of canvas items to a canvas referred by the first argument. addCanvas :: WidgetRef -> [CanvasItem] -> GuiPort -> IO () addCanvas (WRefLabel var wtype) items gport = do send2tk (config2tcl wtype (wRefname2Label var) (CanvasItems items)) gport ---------------------------------------------------------------------------- -- Example GUIs: ---------------------------------------------------------------------------- --- A simple popup message. popupMessage :: String -> IO () popupMessage s = runGUI "" (Col [] [Label [Text s], Button exitGUI [Text "Dismiss"]]) --- A simple event handler that can be associated to a widget. --- The event handler takes a GUI port as parameter in order to --- read or write values from/into the GUI. Cmd :: (GuiPort -> IO ()) -> ConfItem Cmd cmd = Command (\gport -> cmd gport >> return []) --- An event handler that can be associated to a widget. --- The event handler takes a GUI port as parameter (in order to --- read or write values from/into the GUI) and returns a list --- of widget reference/configuration pairs --- which is applied after the handler in order to configure some GUI widgets. Command :: (GuiPort -> IO [ReconfigureItem]) -> ConfItem Command cmd = Handler DefaultEvent cmd --- A button with an associated event handler which is activated --- if the button is pressed. Button :: (GuiPort -> IO ()) -> [ConfItem] -> Widget Button cmd confs = PlainButton (Cmd cmd : confs) --- A button with an associated event handler which is activated --- if the button is pressed. The event handler is a configuration handler --- (see Command) that allows the configuration of some widgets. ConfigButton :: (GuiPort -> IO [ReconfigureItem]) -> [ConfItem] -> Widget ConfigButton cmd confs = PlainButton (Command cmd : confs) --- A text edit widget with vertical and horizontal scrollbars. --- The argument contains the configuration options for the text edit widget. TextEditScroll :: [ConfItem] -> Widget TextEditScroll confs = Matrix [] [[TextEdit ([WRef txtref, Fill]++confs), ScrollV txtref [FillY]], [ScrollH txtref [FillX]]] where txtref free --- A list box widget with vertical and horizontal scrollbars. --- The argument contains the configuration options for the list box widget. ListBoxScroll :: [ConfItem] -> Widget ListBoxScroll confs = Matrix [] [[ListBox ([WRef lbref, Fill]++confs), ScrollV lbref [FillY]], [ScrollH lbref [FillX]]] where lbref free --- A canvas widget with vertical and horizontal scrollbars. --- The argument contains the configuration options for the text edit widget. CanvasScroll :: [ConfItem] -> Widget CanvasScroll confs = Col [] [Row [] [Canvas ([WRef cref, Fill]++confs), ScrollV cref [FillY]], ScrollH cref [FillX]] where cref free --- An entry widget with a horizontal scrollbar. --- The argument contains the configuration options for the entry widget. EntryScroll :: [ConfItem] -> Widget EntryScroll confs = Col [] [Entry ([WRef entryref, FillX]++confs), ScrollH entryref [Width 10, FillX]] where entryref free --- Pops up a GUI for selecting an existing file. --- The file with its full path name will be returned (or "" if the user --- cancels the selection). getOpenFile :: IO String getOpenFile = getOpenFileWithTypes [] --- Pops up a GUI for selecting an existing file. The parameter is --- a list of pairs of file types that could be selected. --- A file type pair consists of a name and an extension for that file type. --- The file with its full path name will be returned (or "" if the user --- cancels the selection). getOpenFileWithTypes :: [(String,String)] -> IO String getOpenFileWithTypes filetypes = do gport <- openWish "" "" send2tk ("wm withdraw .\nputs [tk_getOpenFile" ++ (if null filetypes then "" else " -filetypes {"++ concatMap (\(x,y)->"{{"++x++"} {"++y++"}} ") filetypes ++"}") ++ "]\n") gport filename <- receiveFromTk gport exitGUI gport return filename --- Pops up a GUI for choosing a file to save some data. --- If the user chooses an existing file, she/he will asked to confirm --- to overwrite it. --- The file with its full path name will be returned (or "" if the user --- cancels the selection). getSaveFile :: IO String getSaveFile = getSaveFileWithTypes [] --- Pops up a GUI for choosing a file to save some data. The parameter is --- a list of pairs of file types that could be selected. --- A file type pair consists of a name and an extension for that file type. --- If the user chooses an existing file, she/he will asked to confirm --- to overwrite it. --- The file with its full path name will be returned (or "" if the user --- cancels the selection). getSaveFileWithTypes :: [(String,String)] -> IO String getSaveFileWithTypes filetypes = do gport <- openWish "" "" send2tk ("wm withdraw .\nputs [tk_getSaveFile" ++ (if null filetypes then "" else " -filetypes {"++ concatMap (\(x,y)->"{{"++x++"} {"++y++"}} ") filetypes ++"}") ++ "]\n") gport filename <- receiveFromTk gport exitGUI gport return filename --- Pops up a GUI dialog box to select a color. --- The name of the color will be returned (or "" if the user --- cancels the selection). chooseColor :: IO String chooseColor = do gport <- openWish "" "" send2tk "wm withdraw .\nputs [tk_chooseColor]" gport color <- receiveFromTk gport exitGUI gport return color -- end of GUI library curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/GetOpt.curry000066400000000000000000000414751305333611600235330ustar00rootroot00000000000000--- ----------------------------------------------------------------- --- This Module is a modified version of the Module --- System.Console.GetOpt by Sven Panne from the ghc-base package --- it has been adapted for Curry by Bjoern Peemoeller --- --- (c) Sven Panne 2002-2005 --- The Glasgow Haskell Compiler License --- --- Copyright 2004, The University Court of the University of Glasgow. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- - Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright notice, --- this list of conditions and the following disclaimer in the documentation --- and/or other materials provided with the distribution. --- --- - Neither name of the University nor the names of its contributors may be --- used to endorse or promote products derived from this software without --- specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF --- GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, --- INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND --- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE --- UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE --- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL --- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER --- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT --- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY --- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH --- DAMAGE. --- --- @category general --- --------------------------------------------------------------------------- {- Two rather obscure features are missing: The Bash 2.0 non-option hack (if you don't already know it, you probably don't want to hear about it...) and the recognition of long options with a single dash (e.g. '-help' is recognised as '--help', as long as there is no short option 'h'). Other differences between GNU's getopt and this implementation: * To enforce a coherent description of options and arguments, there are explanation fields in the option/argument descriptor. * Error messages are now more informative, but no longer POSIX compliant... :-( -} module GetOpt -- * GetOpt ( getOpt, getOpt', usageInfo, ArgOrder (..), OptDescr (..), ArgDescr (..) -- * Examples -- |To hopefully illuminate the role of the different data structures, -- here are the command-line options for a (very simple) compiler, -- done in two different ways. -- The difference arises because the type of 'getOpt' is -- parameterized by the type of values derived from flags. -- ** Interpreting flags as concrete values -- $example1 -- ** Interpreting flags as transformations of an options record -- $example2 ) where import Prelude -- necessary to get dependencies right import List (isPrefixOf, find) -- |What to do with options following non-options data ArgOrder a = RequireOrder -- ^ no option processing after first non-option | Permute -- ^ freely intersperse options and non-options | ReturnInOrder (String -> a) -- ^ wrap non-options into options {-| Each 'OptDescr' describes a single option. The arguments to 'Option' are: * list of short option characters * list of long option strings (without \"--\") * argument descriptor * explanation of option for user -} data OptDescr a = -- description of a single options: Option [Char] -- list of short option characters [String] -- list of long option strings (without "--") (ArgDescr a) -- argument descriptor String -- explanation of option for user -- |Describes whether an option takes an argument or not, and if so -- how the argument is injected into a value of type @a@. data ArgDescr a = NoArg a -- ^no argument expected | ReqArg (String -> a) String -- ^option requires argument | OptArg (Maybe String -> a) String -- ^optional argument data OptKind a -- kind of cmd line arg (internal use only): = Opt a -- an option | UnreqOpt String -- an un-recognized option | NonOpt String -- a non-option | EndOfOpts -- end-of-options marker (i.e. "--") | OptErr String -- something went wrong... -- | Return a string describing the usage of a command, derived from -- the header (first argument) and the options described by the -- second argument. usageInfo :: String -- header -> [OptDescr a] -- option descriptors -> String -- nicely formatted decription of options usageInfo header optDescr = unlines (header:table) where (ss,ls,ds) = (unzip3 . concatMap fmtOpt) optDescr table = zipWith3 paste (sameLen ss) (sameLen ls) ds paste x y z = " " ++ x ++ " " ++ y ++ " " ++ z sameLen xs = flushLeft ((maximum . map length) xs) xs flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ] maximum :: [a] -> a maximum [] = error "maximum with empty list" maximum xs@(_:_) = foldl1 max xs fmtOpt :: OptDescr a -> [(String,String,String)] fmtOpt (Option sos los ad descr) = case lines descr of [] -> [(sosFmt,losFmt,"")] (d:ds) -> (sosFmt,losFmt,d) : [ ("","",d') | d' <- ds ] where sepBy _ [] = "" sepBy _ [x] = x sepBy ch (x:y:xs) = x ++ ch : ' ' : sepBy ch (y:xs) sosFmt = sepBy ',' (map (fmtShort ad) sos) losFmt = sepBy ',' (map (fmtLong ad) los) fmtShort :: ArgDescr a -> Char -> String fmtShort (NoArg _ ) so = "-" ++ [so] fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]" fmtLong :: ArgDescr a -> String -> String fmtLong (NoArg _ ) lo = "--" ++ lo fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" {-| Process the command-line, and return the list of values that matched (and those that didn\'t). The arguments are: * The order requirements (see 'ArgOrder') * The option descriptions (see 'OptDescr') * The actual command line arguments (presumably got from 'System.Environment.getArgs'). 'getOpt' returns a triple consisting of the option arguments, a list of non-options, and a list of error messages. -} getOpt :: ArgOrder a -- non-option handling -> [OptDescr a] -- option descriptors -> [String] -- the command-line arguments -> ([a],[String],[String]) -- (options,non-options,error messages) getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us) where (os,xs,us,es) = getOpt' ordering optDescr args {-| This is almost the same as 'getOpt', but returns a quadruple consisting of the option arguments, a list of non-options, a list of unrecognized options, and a list of error messages. -} getOpt' :: ArgOrder a -- non-option handling -> [OptDescr a] -- option descriptors -> [String] -- the command-line arguments -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages) getOpt' _ _ [] = ([],[],[],[]) getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering where procNextOpt (Opt o) _ = (o:os,xs,us,es) procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es) procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[]) procNextOpt (NonOpt x) Permute = (os,x:xs,us,es) procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es) procNextOpt EndOfOpts RequireOrder = ([],rest,[],[]) procNextOpt EndOfOpts Permute = ([],rest,[],[]) procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[]) procNextOpt (OptErr e) _ = (os,xs,us,e:es) (opt,rest) = getNext arg args optDescr (os,xs,us,es) = getOpt' ordering optDescr rest -- take a look at the next cmd line arg and decide what to do with it getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) getNext s rest optDescr = case s of '-':'-':[] -> (EndOfOpts, rest) '-':'-':xs -> longOpt xs rest optDescr '-': x :xs -> shortOpt x xs rest optDescr _ -> (NonOpt s,rest) -- handle long option longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) longOpt ls rs optDescr = long ads arg rs where (opt,arg) = break (=='=') ls getWith p = [ o | o@(Option _ xs _ _) <- optDescr , find (p opt) xs /= Nothing ] exact = getWith (==) options = if null exact then getWith isPrefixOf else exact ads = [ ad | Option _ _ ad _ <- options ] optStr = ("--"++opt) long ads0 arg0 rs0 = case (ads0, arg0, rs0) of ((_:_:_) , _ , rest ) -> (errAmbig options optStr,rest) ([NoArg a ], [] , rest ) -> (Opt a ,rest) ([NoArg _ ], ('=':_) , rest ) -> (errNoArg optStr ,rest) ([ReqArg _ d], [] , [] ) -> (errReq d optStr ,[] ) ([ReqArg f _], [] , (r:rest)) -> (Opt (f r) ,rest) ([ReqArg f _], ('=':xs), rest ) -> (Opt (f xs) ,rest) ([OptArg f _], [] , rest ) -> (Opt (f Nothing) ,rest) ([OptArg f _], ('=':xs), rest ) -> (Opt (f (Just xs)) ,rest) (_ , _ , rest ) -> (UnreqOpt ("--" ++ ls) ,rest) -- handle short option shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String]) shortOpt y ys rs optDescr = short ads ys rs where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ] ads = [ ad | Option _ _ ad _ <- options ] optStr = '-':[y] short [] [] rest = (UnreqOpt optStr,rest) short [] xs@(_:_) rest = (UnreqOpt optStr,('-':xs):rest) short [NoArg a ] [] rest = (Opt a,rest) short [NoArg a ] xs@(_:_) rest = (Opt a,('-':xs):rest) short [ReqArg _ d] [] [] = (errReq d optStr,[]) short [ReqArg f _] [] (r:rest) = (Opt (f r),rest) short [ReqArg f _] xs@(_:_) rest = (Opt (f xs),rest) short [OptArg f _] [] rest = (Opt (f Nothing),rest) short [OptArg f _] xs@(_:_) rest = (Opt (f (Just xs)),rest) short (_:_:_) _ rest = (errAmbig options optStr,rest) -- miscellaneous error formatting errAmbig :: [OptDescr a] -> String -> OptKind a errAmbig ods optStr = OptErr (usageInfo header ods) where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" errReq :: String -> String -> OptKind a errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") errUnrec :: String -> String errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n" errNoArg :: String -> OptKind a errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n") {- ----------------------------------------------------------------------------------------- -- and here a small and hopefully enlightening example: data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show options :: [OptDescr Flag] options = [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files", Option ['V','?'] ["version","release"] (NoArg Version) "show version info", Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump", Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"] out :: Maybe String -> Flag out Nothing = Output "stdout" out (Just o) = Output o test :: ArgOrder Flag -> [String] -> String test order cmdline = case getOpt order options cmdline of (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n" (_,_,errs) -> concat errs ++ usageInfo header options where header = "Usage: foobar [OPTION...] files..." -- example runs: -- putStr (test RequireOrder ["foo","-v"]) -- ==> options=[] args=["foo", "-v"] -- putStr (test Permute ["foo","-v"]) -- ==> options=[Verbose] args=["foo"] -- putStr (test (ReturnInOrder Arg) ["foo","-v"]) -- ==> options=[Arg "foo", Verbose] args=[] -- putStr (test Permute ["foo","--","-v"]) -- ==> options=[] args=["foo", "-v"] -- putStr (test Permute ["-?o","--name","bar","--na=baz"]) -- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[] -- putStr (test Permute ["--ver","foo"]) -- ==> option `--ver' is ambiguous; could be one of: -- -v --verbose verbosely list files -- -V, -? --version, --release show version info -- Usage: foobar [OPTION...] files... -- -v --verbose verbosely list files -- -V, -? --version, --release show version info -- -o[FILE] --output[=FILE] use FILE for dump -- -n USER --name=USER only dump USER's files ----------------------------------------------------------------------------------------- -} {- $example1 A simple choice for the type associated with flags is to define a type @Flag@ as an algebraic type representing the possible flags and their arguments: > module Opts1 where > > import System.Console.GetOpt > import Data.Maybe ( fromMaybe ) > > data Flag > = Verbose | Version > | Input String | Output String | LibDir String > deriving Show > > options :: [OptDescr Flag] > options = > [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr" > , Option ['V','?'] ["version"] (NoArg Version) "show version number" > , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE" > , Option ['c'] [] (OptArg inp "FILE") "input FILE" > , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory" > ] > > inp,outp :: Maybe String -> Flag > outp = Output . fromMaybe "stdout" > inp = Input . fromMaybe "stdin" > > compilerOpts :: [String] -> IO ([Flag], [String]) > compilerOpts argv = > case getOpt Permute options argv of > (o,n,[] ) -> return (o,n) > (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) > where header = "Usage: ic [OPTION...] files..." Then the rest of the program will use the constructed list of flags to determine it\'s behaviour. -} {- $example2 A different approach is to group the option values in a record of type @Options@, and have each flag yield a function of type @Options -> Options@ transforming this record. > module Opts2 where > > import System.Console.GetOpt > import Data.Maybe ( fromMaybe ) > > data Options = Options > { optVerbose :: Bool > , optShowVersion :: Bool > , optOutput :: Maybe FilePath > , optInput :: Maybe FilePath > , optLibDirs :: [FilePath] > } deriving Show > > defaultOptions = Options > { optVerbose = False > , optShowVersion = False > , optOutput = Nothing > , optInput = Nothing > , optLibDirs = [] > } > > options :: [OptDescr (Options -> Options)] > options = > [ Option ['v'] ["verbose"] > (NoArg (\ opts -> opts { optVerbose = True })) > "chatty output on stderr" > , Option ['V','?'] ["version"] > (NoArg (\ opts -> opts { optShowVersion = True })) > "show version number" > , Option ['o'] ["output"] > (OptArg ((\ f opts -> opts { optOutput = Just f }) . fromMaybe "output") > "FILE") > "output FILE" > , Option ['c'] [] > (OptArg ((\ f opts -> opts { optInput = Just f }) . fromMaybe "input") > "FILE") > "input FILE" > , Option ['L'] ["libdir"] > (ReqArg (\ d opts -> opts { optLibDirs = optLibDirs opts ++ [d] }) "DIR") > "library directory" > ] > > compilerOpts :: [String] -> IO (Options, [String]) > compilerOpts argv = > case getOpt Permute options argv of > (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n) > (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) > where header = "Usage: ic [OPTION...] files..." Similarly, each flag could yield a monadic function transforming a record, of type @Options -> IO Options@ (or any other monad), allowing option processing to perform actions of the chosen monad, e.g. printing help or version messages, checking that file arguments exist, etc. -} curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Global.curry000066400000000000000000000051561305333611600235250ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for handling global entities. --- A global entity has a name declared in the program. --- Its value can be accessed and modified by IO actions. --- Furthermore, global entities can be declared as persistent so that --- their values are stored across different program executions. --- --- Currently, it is still experimental so that its interface might --- be slightly changed in the future. --- --- A global entity `g` with an initial value `v` --- of type `t` must be declared by: --- --- g :: Global t --- g = global v spec --- --- Here, the type `t` must not contain type variables and --- `spec` specifies the storage mechanism for the --- global entity (see type `GlobalSpec`). --- --- --- @author Michael Hanus --- @version February 2017 --- @category general ------------------------------------------------------------------------------ module Global( Global, GlobalSpec(..), global , readGlobal, safeReadGlobal, writeGlobal) where ---------------------------------------------------------------------- --- The abstract type of a global entity. data Global _ -- a = GlobalDef a GlobalSpec --- global is only used for the declaration of a global value --- and should not be used elsewhere. In the future, it might become a keyword. global :: a -> GlobalSpec -> Global a global external --v s = GlobalDef v s --- The storage mechanism for the global entity. --- @cons Temporary - the global value exists only during a single execution --- of a program --- @cons Persistent f - the global value is stored persisently in file f --- (which is created and initialized if it does not exists) data GlobalSpec = Temporary | Persistent String --- Reads the current value of a global. readGlobal :: Global a -> IO a readGlobal g = prim_readGlobal $# g prim_readGlobal :: Global a -> IO a prim_readGlobal external --- Safely reads the current value of a global. --- If `readGlobal` fails (e.g., due to a corrupted persistent storage), --- the global is re-initialized with the default value given as --- the second argument. safeReadGlobal :: Global a -> a -> IO a safeReadGlobal g dflt = catch (readGlobal g) (\_ -> writeGlobal g dflt >> return dflt) --- Updates the value of a global. --- The value is evaluated to a ground constructor term before it is updated. writeGlobal :: Global a -> a -> IO () writeGlobal g v = (prim_writeGlobal $# g) $## v prim_writeGlobal :: Global a -> a -> IO () prim_writeGlobal external ------------------------------------------------------------------------ curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Global.curry.pakcs000066400000000000000000000051361305333611600246230ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for handling global entities. --- A global entity has a name declared in the program. --- Its value can be accessed and modified by IO actions. --- Furthermore, global entities can be declared as persistent so that --- their values are stored across different program executions. --- --- Currently, it is still experimental so that its interface might --- be slightly changed in the future. --- --- A global entity `g` with an initial value `v` --- of type `t` must be declared by: --- --- g :: Global t --- g = global v spec --- --- Here, the type `t` must not contain type variables and --- `spec` specifies the storage mechanism for the --- global entity (see type `GlobalSpec`). --- --- --- @author Michael Hanus --- @version February 2017 --- @category general ------------------------------------------------------------------------------ module Global( Global, GlobalSpec(..), global , readGlobal, safeReadGlobal, writeGlobal) where ---------------------------------------------------------------------- --- The abstract type of a global entity. data Global a = GlobalDef a GlobalSpec --- global is only used for the declaration of a global value --- and should not be used elsewhere. In the future, it might become a keyword. global :: a -> GlobalSpec -> Global a global v s = GlobalDef v s --- The storage mechanism for the global entity. --- @cons Temporary - the global value exists only during a single execution --- of a program --- @cons Persistent f - the global value is stored persisently in file f --- (which is created and initialized if it does not exists) data GlobalSpec = Temporary | Persistent String --- Reads the current value of a global. readGlobal :: Global a -> IO a readGlobal g = prim_readGlobal $# g prim_readGlobal :: Global a -> IO a prim_readGlobal external --- Safely reads the current value of a global. --- If `readGlobal` fails (e.g., due to a corrupted persistent storage), --- the global is re-initialized with the default value given as --- the second argument. safeReadGlobal :: Global a -> a -> IO a safeReadGlobal g dflt = catch (readGlobal g) (\_ -> writeGlobal g dflt >> return dflt) --- Updates the value of a global. --- The value is evaluated to a ground constructor term before it is updated. writeGlobal :: Global a -> a -> IO () writeGlobal g v = (prim_writeGlobal $# g) $## v prim_writeGlobal :: Global a -> a -> IO () prim_writeGlobal external ------------------------------------------------------------------------ curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Global.prim_c2p000066400000000000000000000006261305333611600240710ustar00rootroot00000000000000 prim_global prim_readGlobal prim_global prim_writeGlobal curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/GlobalVariable.curry.pakcs000066400000000000000000000045311305333611600262670ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for handling global variables. --- A global variable has a name declared in the program. --- Its value (a data term possibly containing free variables) --- can be accessed and modified by IO actions. --- --- In contast to global entities (as defined in the library Global), --- global variables can contain logic variables shared with --- computations running in the same computation space. --- As a consequence, global variables cannot be persistent, --- their values are not kept across different program executions. --- --- Currently, it is still experimental so that its interface might --- be slightly changed in the future. --- --- A global variable g with an initial value v --- of type t must be declared by: --- --- g :: GVar t
--- g = gvar v --- --- Here, the type t must not contain type variables. --- v is the initial value for every program run. --- --- Note: the implementation in PAKCS is based on threading a state --- through the execution. Thus, it might be the case that --- some updates of global variables are lost if fancy features --- like unsafe operations or debugging support are used. --- --- @author Michael Hanus --- @version March 2010 --- @category general ------------------------------------------------------------------------------ module GlobalVariable(GVar,gvar,writeGVar,readGVar) where --- The general type of global variables. data GVar a = GVarDef a | GVarValue () a --- gvar is only used for the declaration of a global variable --- and should not be used elsewhere. In the future, it might become a keyword. gvar :: a -> GVar a gvar v = GVarDef v ---------------------------------------------------------------------- --- Reads the current value of a global variable. readGVar :: GVar a -> IO a readGVar gv = prim_readGVar $# gv prim_readGVar :: GVar a -> IO a prim_readGVar external --- Updates the value of a global variable. --- The associated term is evaluated to a data term and might --- contain free variables. writeGVar :: GVar a -> a -> IO () writeGVar gv val = (prim_writeGVar $# gv) $!! val prim_writeGVar :: GVar a -> a -> IO () prim_writeGVar external ------------------------------------------------------------------------ curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/GlobalVariable.prim_c2p000066400000000000000000000006361305333611600255400ustar00rootroot00000000000000 prim_globalvar prim_readGVar[raw] prim_globalvar prim_writeGVar[raw] curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/GraphInductive.curry000066400000000000000000000375521305333611600252460ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for inductive graphs (port of a Haskell library by Martin Erwig). --- --- In this library, graphs are composed and decomposed in an inductive way. --- --- The key idea is as follows: --- --- A graph is either empty or it consists of node context --- and a graph g' which --- are put together by a constructor `(:&)`. --- --- This constructor `(:&)`, however, is not a constructor in --- the sense of abstract --- data type, but more basically a defined constructing funtion. --- --- A context is a node together withe the edges to and from this node --- into the nodes in the graph g'. --- --- For examples of how to use this library, cf. the module `GraphAlgorithms`. --- --- @author Bernd Brassel --- @version May 2005 --- @category algorithm ------------------------------------------------------------------------------ module GraphInductive ( empty, mkGraph, buildGr, mkUGraph, (:&), insNode, insNodes, insEdge, insEdges, delNode, delNodes, delEdge, delEdges, isEmpty, match, matchAny, noNodes, nodeRange, context, lab, neighbors, suc,lsuc, pre,lpre, out,outdeg, inn,indeg, deg, gelem, equal, node', lab', labNode', neighbors', suc',lsuc', pre',lpre', out',outdeg', inn',indeg', deg', labNodes, labEdges, nodes, edges, newNodes, ufold, gmap,nmap,emap, labUEdges,labUNodes, showGraph, Graph, Node,LNode,UNode, Edge,LEdge,UEdge, Context,MContext,Context',UContext, GDecomp,Decomp,UDecomp, Path,LPath,UPath, UGr) where import FiniteMap import Sort (mergeSortBy) import Maybe infixr 5 .: --------------------------------------- --- Graph composition --------------------------------------- infixr 5 :& --- (:&) takes a node-context and a Graph and yields a new graph. --- --- The according key idea is detailed at the beginning. --- --- nl is the type of the node labels and el the edge labels. --- --- Note that it is an error to induce a context for --- a node already contained in the graph. (:&) :: Context nl el -> Graph nl el -> Graph nl el (p,v,l,s) :& (Gr g) | elemFM v g = error ("Node Exception, Node: "++show v++": "++show l) | otherwise = Gr g3 where g1 = addToFM g v (p,l,s) g2 = updAdj g1 p (addSucc v) g3 = updAdj g2 s (addPred v) --- The type variables of Graph are nodeLabel and edgeLabel. --- The internal representation of Graph is hidden. data Graph nodeLabel edgeLabel = Gr (GraphRep nodeLabel edgeLabel) --- Nodes and edges themselves (in contrast to their labels) are coded as integers. --- --- For both of them, there are variants as labeled, unlabelwd and quasi unlabeled --- (labeled with ()). --- -- Nodes and their labels --- --- Unlabeled node type Node = Int --- Labeled node type LNode a = (Node,a) --- Quasi-unlabeled node type UNode = LNode () -- Edges and their labels --- Unlabeled edge type Edge = (Node,Node) --- Labeled edge type LEdge b = (Node,Node,b) --- Quasi-unlabeled edge type UEdge = LEdge () --- The context of a node is the node itself (along with label) and its adjacent nodes. --- Thus, a context is a quadrupel, for node n it is of the form --- (edges to n,node n,n's label,edges from n) type Context a b = (Adj b,Node,a,Adj b) -- Context a b "=" Context' a b "+" Node --- Labeled links to or from a 'Node'. type Adj b = [(b,Node)] -- there are some useful variants of the context type --- maybe context type MContext a b = Maybe (Context a b) --- context with edges and node label only, without the node identifier itself type Context' a b = (Adj b,a,Adj b) --- Unlabeled context. type UContext = ([Node],Node,[Node]) ------------------------------------ -- graph decomposition ------------------------------------ --- decompose a graph into the 'Context' for an arbitrarily-chosen 'Node' --- and the remaining 'Graph'. --- --- In order to use graphs as abstract data structures, we also need means to --- decompose a graph. This decompostion should work as much like pattern matching --- as possible. The normal matching is done by the function matchAny, which takes --- a graph and yields a graph decompostion. --- --- According to the main idea, matchAny . (:&) should be an identity. matchAny :: Graph a b -> GDecomp a b matchAny (Gr g) | isEmptyFM g = error "Match Exception, Empty Graph" | otherwise = case head (fmToListPreOrder g) of (v,_) -> case match v (Gr g) of (Just c,g') -> (c,g') --- A graph decompostion is a context for a node n and the remaining graph without --- that node. type GDecomp a b = (Context a b,Graph a b) --- a decomposition with a maybe context type Decomp a b = (MContext a b,Graph a b) --- Unlabeled decomposition. type UDecomp g = (Maybe UContext,g) ---------------------------------------------------------------------- -- basic graph operations ---------------------------------------------------------------------- ---------------------------------- -- creating graphs ---------------------------------- --- An empty 'Graph'. -- internal representation by finite maps empty :: Graph _ _ empty = Gr (emptyFM (<)) --- Create a 'Graph' from the list of 'LNode's and 'LEdge's. mkGraph :: [LNode a] -> [LEdge b] -> Graph a b mkGraph vs es = (insEdges es . insNodes vs) empty --- Build a 'Graph' from a list of 'Context's. buildGr :: [Context a b] -> Graph a b buildGr = foldr (:&) empty --- Build a quasi-unlabeled 'Graph' from the list of 'Node's and 'Edge's. mkUGraph :: [Node] -> [Edge] -> Graph () () mkUGraph vs es = mkGraph (labUNodes vs) (labUEdges es) ---------------------------------------------- -- adding to and deleting from graphs ---------------------------------------------- --- Insert a 'LNode' into the 'Graph'. insNode :: LNode a -> Graph a b -> Graph a b insNode (v,l) = (([],v,l,[]):&) --- Insert a 'LEdge' into the 'Graph'. insEdge :: LEdge b -> Graph a b -> Graph a b insEdge (v,w,l) g = (pr,v,la,(l,w):su) :& g' where (Just (pr,_,la,su),g') = match v g --- Remove a 'Node' from the 'Graph'. delNode :: Node -> Graph a b -> Graph a b delNode v = delNodes [v] --- Remove an 'Edge' from the 'Graph'. delEdge :: Edge -> Graph a b -> Graph a b delEdge (v,w) g = case match v g of (Nothing,_) -> g (Just (p,v',l,s),g') -> (p,v',l,filter ((/=w).snd) s) :& g' --- Insert multiple 'LNode's into the 'Graph'. insNodes :: [LNode a] -> Graph a b -> Graph a b insNodes vs g = foldr insNode g vs --- Insert multiple 'LEdge's into the 'Graph'. insEdges :: [LEdge b] -> Graph a b -> Graph a b insEdges es g = foldr insEdge g es --- Remove multiple 'Node's from the 'Graph'. delNodes :: [Node] -> Graph a b -> Graph a b delNodes [] g = g delNodes (v:vs) g = delNodes vs (snd (match v g)) --- Remove multiple 'Edge's from the 'Graph'. delEdges :: [Edge] -> Graph a b -> Graph a b delEdges es g = foldr delEdge g es ----------------------------------------- -- retrieving information about graphs ----------------------------------------- --- test if the given 'Graph' is empty. isEmpty :: Graph _ _ -> Bool isEmpty (Gr g) = isEmptyFM g --- match is the complement side of (:&), decomposing a 'Graph' into the --- 'MContext' found for the given node and the remaining 'Graph'. match :: Node -> Graph a b -> Decomp a b match v (Gr g) = maybe (Nothing,Gr g) (\ (g',(_,(p,l,s))) -> let s' = filter ((/=v) . snd) s p' = filter ((/=v) . snd) p g1 = updAdj g' s' (clearPred v) g2 = updAdj g1 p' (clearSucc v) in (Just (p',v,l,s),Gr g2)) (splitFM g v) --- The number of 'Node's in a 'Graph'. noNodes :: Graph _ _ -> Int noNodes (Gr g) = sizeFM g --- The minimum and maximum 'Node' in a 'Graph'. nodeRange :: Graph _ _ -> (Node,Node) nodeRange (Gr g) | isEmptyFM g = (0,0) | otherwise = (ix (minFM g),ix (maxFM g)) where ix = fst . fromJust --- Find the context for the given 'Node'. In contrast to "match", --- "context" causes an error if the 'Node' is --- not present in the 'Graph'. context :: Graph a b -> Node -> Context a b context g v = case match v g of (Nothing,_) -> error ("Match Exception, Node: "++show v) (Just c,_) -> c --- Find the label for a 'Node'. lab :: Graph a _ -> Node -> Maybe a lab g v = fst (match v g) >>- Just . lab' --- Find the neighbors for a 'Node'. neighbors :: Graph _ _ -> Node -> [Node] neighbors = (\(p,_,_,s) -> map snd (p++s)) .: context --- Find all 'Node's that have a link from the given 'Node'. suc :: Graph _ _ -> Node -> [Node] suc = map snd .: context4 --- Find all 'Node's that link to to the given 'Node'. pre :: Graph _ _ -> Node -> [Node] pre = map snd .: context1 --- Find all Nodes and their labels, which are linked from the given 'Node'. lsuc :: Graph _ b -> Node -> [(Node,b)] lsuc = map flip2 .: context4 --- Find all 'Node's that link to the given 'Node' and the label of each link. lpre :: Graph _ b -> Node -> [(Node,b)] lpre = map flip2 .: context1 --- Find all outward-bound 'LEdge's for the given 'Node'. out :: Graph _ b -> Node -> [LEdge b] out g v = map (\(l,w)->(v,w,l)) (context4 g v) --- Find all inward-bound 'LEdge's for the given 'Node'. inn :: Graph _ b -> Node -> [LEdge b] inn g v = map (\(l,w)->(w,v,l)) (context1 g v) --- The outward-bound degree of the 'Node'. outdeg :: Graph _ _ -> Node -> Int outdeg = length .: context4 --- The inward-bound degree of the 'Node'. indeg :: Graph _ _ -> Node -> Int indeg = length .: context1 --- The degree of the 'Node'. deg :: Graph _ _ -> Node -> Int deg = (\(p,_,_,s) -> length p+length s) .: context --- 'True' if the 'Node' is present in the 'Graph'. gelem :: Node -> Graph _ _ -> Bool gelem v g = isJust (fst (match v g)) --- graph equality equal :: Graph a b -> Graph a b -> Bool equal g g' = slabNodes g == slabNodes g' && slabEdges g == slabEdges g' -- comparing nodes nodeComp :: LNode b -> LNode b -> Ordering nodeComp n n' | n == n' = EQ | fst n [LNode a] slabNodes = sortBy nodeComp . labNodes -- comparing edges edgeComp :: LEdge b -> LEdge b -> Ordering edgeComp e e' | e == e' = EQ | v [LEdge b] slabEdges = sortBy edgeComp . labEdges ------------------------------------------- -- retrieving information from contexts ------------------------------------------- --- The 'Node' in a 'Context'. node' :: Context _ _ -> Node node' (_,v,_,_) = v --- The label in a 'Context'. lab' :: Context a _ -> a lab' (_,_,l,_) = l --- The 'LNode' from a 'Context'. labNode' :: Context a _ -> LNode a labNode' (_,v,l,_) = (v,l) --- All 'Node's linked to or from in a 'Context'. neighbors' :: Context _ _ -> [Node] neighbors' (p,_,_,s) = map snd p++map snd s --- All 'Node's linked to in a 'Context'. suc' :: Context _ _ -> [Node] suc' (_,_,_,s) = map snd s --- All 'Node's linked from in a 'Context'. pre' :: Context _ _ -> [Node] pre' (p,_,_,_) = map snd p --- All 'Node's linked from in a 'Context', and the label of the links. lpre' :: Context _ b -> [(Node,b)] lpre' (p,_,_,_) = map flip2 p --- All 'Node's linked from in a 'Context', and the label of the links. lsuc' :: Context _ b -> [(Node,b)] lsuc' (_,_,_,s) = map flip2 s --- All outward-directed 'LEdge's in a 'Context'. out' :: Context _ b -> [LEdge b] out' (_,v,_,s) = map (\(l,w)->(v,w,l)) s --- All inward-directed 'LEdge's in a 'Context'. inn' :: Context _ b -> [LEdge b] inn' (p,v,_,_) = map (\(l,w)->(w,v,l)) p --- The outward degree of a 'Context'. outdeg' :: Context _ _ -> Int outdeg' (_,_,_,s) = length s --- The inward degree of a 'Context'. indeg' :: Context _ _ -> Int indeg' (p,_,_,_) = length p --- The degree of a 'Context'. deg' :: Context _ _ -> Int deg' (p,_,_,s) = length p+length s ------------------------------------ -- listifying graphs ------------------------------------ --- A list of all 'LNode's in the 'Graph'. labNodes (Gr g) = map (\(v,(_,l,_))->(v,l)) (fmToList g) --- A list of all 'LEdge's in the 'Graph'. labEdges :: Graph _ b -> [LEdge b] labEdges (Gr g) = concatMap (\(v,(_,_,s))->map (\(l,w)->(v,w,l)) s) (fmToList g) --- List all 'Node's in the 'Graph'. nodes :: Graph _ _ -> [Node] nodes = map fst . labNodes --- List all 'Edge's in the 'Graph'. edges :: Graph _ _ -> [Edge] edges = map (\(v,w,_)->(v,w)) . labEdges --- List N available 'Node's, ie 'Node's that are not used in the 'Graph'. newNodes :: Int -> Graph _ _ -> [Node] newNodes i g = [n+1..n+i] where (_,n) = nodeRange g ------------------------------------ -- some convenient type synonyms ------------------------------------ -- Paths and their labels --- Unlabeled path type Path = [Node] --- Labeled path type LPath a = [LNode a] --- Quasi-unlabeled path type UPath = [UNode] type GraphRep a b = FM Node (Context' a b) --- a graph without any labels type UGr = Graph () () ------------------------ -- Functions on Graphs ------------------------ --- Fold a function over the graph. ufold :: ((Context a b) -> c -> c) -> c -> Graph a b -> c ufold f u g | isEmpty g = u | otherwise = f c (ufold f u g') where (c,g') = matchAny g --- Map a function over the graph. gmap :: (Context a b -> Context c d) -> Graph a b -> Graph c d gmap f = ufold (\c->((f c):&)) empty --- Map a function over the 'Node' labels in a graph. nmap :: (a -> c) -> Graph a b -> Graph c b nmap f = gmap (\(p,v,l,s)->(p,v,f l,s)) --- Map a function over the 'Edge' labels in a graph. emap :: (b -> c) -> Graph a b -> Graph a c emap f = gmap (\(p,v,l,s)->(map1 f p,v,l,map1 f s)) where map1 g = map (\(l,v)->(g l,v)) --- add label () to list of edges (node,node) labUEdges = map (\(v,w)->(v,w,())) --- add label () to list of nodes labUNodes = map (\v->(v,())) ---------------------------------------------------------------------- -- textual Graph representation ---------------------------------------------------------------------- --- Represent Graph as String showGraph :: Graph _ _ -> String showGraph (Gr g) = unlines (map showNode (fmToList g)) -- showNode (v,(_,l',s)) = show v ++ ":" ++ show l' ++ "->"++ show s ---------------------------------------------------------------------- -- UTILITIES ---------------------------------------------------------------------- -- auxiliary functions used in the implementation of the -- derived class members -- (.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d) -- f .: g = \x y->f (g x y) -- f .: g = (f .) . g -- (.:) f = ((f .) .) -- (.:) = (.) (.) (.) (.:) = (.) . (.) fst4 (x,_,_,_) = x {- not used snd4 (_,x,_,_) = x thd4 (_,_,x,_) = x -} fth4 (_,_,_,x) = x {- not used fst3 (x,_,_) = x snd3 (_,x,_) = x thd3 (_,_,x) = x -} flip2 (x,y) = (y,x) -- projecting on context elements -- -- context1 g v = fst4 (contextP g v) context1 :: Graph _ b -> Node -> Adj b {- not used context2 :: Graph gr => gr a b -> Node -> Node context3 :: Graph gr => gr a b -> Node -> a -} context4 :: Graph _ b -> Node -> Adj b context1 = fst4 .: context {- not used context2 = snd4 .: context context3 = thd4 .: context -} context4 = fth4 .: context addSucc v l (p,l',s) = (p,l',(l,v):s) addPred v l (p,l',s) = ((l,v):p,l',s) clearSucc v _ (p,l,s) = (p,l,filter ((/=v).snd) s) clearPred v _ (p,l,s) = (filter ((/=v).snd) p,l,s) updAdj :: GraphRep a b -> Adj b -> (b -> Context' a b -> Context' a b) -> GraphRep a b updAdj g [] _ = g updAdj g ((l,v):vs) f | elemFM v g = updAdj (updFM g v (f l)) vs f | otherwise = error ("Edge Exception, Node: "++show v) sortBy p = mergeSortBy (\x y -> let pxy = p x y in pxy==EQ||pxy==LT) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/HTML.curry000066400000000000000000002521571305333611600230760ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for HTML and CGI programming. --- [This paper](http://www.informatik.uni-kiel.de/~mh/papers/PADL01.html) --- contains a description of the basic ideas behind this library. --- --- The installation of a cgi script written with this library --- can be done by the command --- --- curry makecgi -m initialForm -o /home/joe/public_html/prog.cgi prog --- --- where `prog` is the name of the Curry program with --- the cgi script, `/home/joe/public_html/prog.cgi` is --- the desired location of the --- compiled cgi script, and `initialForm` is the Curry expression --- (of type IO HtmlForm) computing the HTML form (where `curry` --- is the shell command calling the Curry system PAKCS or KiCS2). --- --- @author Michael Hanus (with extensions by Bernd Brassel and Marco Comini) --- @version October 2016 --- @category web ------------------------------------------------------------------------------ {-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-} module HTML(HtmlExp(..),HtmlPage(..),PageParam(..), HtmlForm(..),FormParam(..),CookieParam(..), CgiRef,idOfCgiRef,CgiEnv,HtmlHandler, defaultEncoding, form,standardForm,answerText,answerEncText, cookieForm,getCookies, page,standardPage, pageEnc,pageCSS,pageMetaInfo,pageLinkInfo,pageBodyAttr,addPageParam, formEnc,formCSS,formMetaInfo,formBodyAttr,addFormParam, htxt,htxts,hempty,nbsp,h1,h2,h3,h4,h5, par,section,header,footer,emphasize,strong,bold,italic,nav,code, center,blink,teletype,pre,verbatim,address,href,anchor, ulist,olist,litem,dlist,table,headedTable,addHeadings, hrule,breakline,image, styleSheet,style,textstyle,blockstyle,inline,block, redirect,expires, button,resetbutton,imageButton,coordinates, textfield,password,textarea,checkbox,checkedbox, radio_main,radio_main_off,radio_other, selection,selectionInitial,multipleSelection, hiddenfield,htmlQuote,htmlIsoUmlauts,addAttr,addAttrs,addClass, showHtmlExps,showHtmlExp,showHtmlPage, runFormServerWithKey,runFormServerWithKeyAndFormParams, intForm,intFormMain, getUrlParameter,urlencoded2string,string2urlencoded, showLatexExps,showLatexExp,showLatexDoc,showLatexDocs, showLatexDocsWithPackages,showLatexDocWithPackages, germanLatexDoc,htmlSpecialChars2tex, addSound,addCookies) where import Char import Directory (getHomeDirectory) import Distribution (installDir) import HtmlCgi import IO import NamedSocket import List import Profile import Random (getRandomSeed, nextInt) import ReadNumeric (readNat, readHex) import ReadShowTerm (showQTerm, readsQTerm) import System import Time --import Unsafe(showAnyQExpression) -- to show status of cgi server infixl 0 `addAttr` infixl 0 `addAttrs` infixl 0 `addClass` infixl 0 `addPageParam` infixl 0 `addFormParam` ------------------------------------------------------------------------------ --- The default encoding used in generated web pages. defaultEncoding :: String defaultEncoding = "utf-8" --"iso-8859-1" ------------------------------------------------------------------------------ --- The (abstract) data type for representing references to input elements --- in HTML forms. data CgiRef = CgiRef String --- Internal identifier of a CgiRef (intended only for internal use in other --- libraries!). idOfCgiRef :: CgiRef -> String idOfCgiRef (CgiRef i) = i --- The type for representing cgi environments --- (i.e., mappings from cgi references to the corresponding values of --- the input elements). type CgiEnv = CgiRef -> String --- The type of event handlers in HTML forms. type HtmlHandler = CgiEnv -> IO HtmlForm --- The data type for representing HTML expressions. --- @cons HtmlText s - a text string without any further structure --- @cons HtmlStruct t as hs - a structure with a tag, attributes, and --- HTML expressions inside the structure --- @cons HtmlCRef h ref - an input element (described by the first argument) --- with a cgi reference --- @cons HtmlEvent h hdlr - an input element (first arg) with an associated --- event handler (tpyically, a submit button) data HtmlExp = HtmlText String | HtmlStruct String [(String,String)] [HtmlExp] | HtmlCRef HtmlExp CgiRef | HtmlEvent HtmlExp HtmlHandler --- Extracts the textual contents of a list of HTML expressions. --- --- For instance, --- textOf [HtmlText "xy", HtmlStruct "a" [] [HtmlText "bc"]] == "xy bc" textOf :: [HtmlExp] -> String textOf = unwords . filter (not . null) . map textOfHtmlExp where textOfHtmlExp (HtmlText s) = s textOfHtmlExp (HtmlStruct _ _ hs) = textOf hs textOfHtmlExp (HtmlCRef hexp _) = textOf [hexp] textOfHtmlExp (HtmlEvent hexp _) = textOf [hexp] ------------------------------------------------------------------------------ --- The data type for representing HTML forms (active web pages) --- and return values of HTML forms. --- @cons HtmlForm t ps hs - an HTML form with title t, optional parameters --- (e.g., cookies) ps, and contents hs --- @cons HtmlAnswer t c - an answer in an arbitrary format where t --- is the content type (e.g., "text/plain") and c is the contents data HtmlForm = HtmlForm String [FormParam] [HtmlExp] | HtmlAnswer String String -- content type (e.g., "text/plain") / content --- The possible parameters of an HTML form. --- The parameters of a cookie (FormCookie) are its name and value and --- optional parameters (expiration date, domain, path (e.g., the path "/" --- makes the cookie valid for all documents on the server), security) which --- are collected in a list. --- @cons FormCookie name value params - a cookie to be sent to the --- client's browser --- @cons FormCSS s - a URL for a CSS file for this form --- @cons FormJScript s - a URL for a Javascript file for this form --- @cons FormOnSubmit s - a JavaScript statement to be executed when the form --- is submitted (i.e., <form ... onsubmit="s">) --- @cons FormTarget s - a name of a target frame where the output of the --- script should be represented (should only be used --- for scripts running in a frame) --- @cons FormEnc - the encoding scheme of this form --- @cons FormMeta as - meta information (in form of attributes) for this form --- @cons HeadInclude he - HTML expression to be included in form header --- @cons MultipleHandlers - indicates that the event handlers of the form --- can be multiply used (i.e., are not deleted if the form is submitted --- so that they are still available when going back in the browser; --- but then there is a higher risk that the web server process --- might overflow with unused events); the default is a single use --- of event handlers, i.e., one cannot use the back button in the --- browser and submit the same form again (which is usually --- a reasonable behavior to avoid double submissions of data). --- @cons BodyAttr ps - optional attribute for the body element (more than --- one occurrence is allowed) data FormParam = FormCookie String String [CookieParam] | FormCSS String | FormJScript String | FormOnSubmit String | FormTarget String | FormEnc String | FormMeta [(String,String)] | HeadInclude HtmlExp | MultipleHandlers | BodyAttr (String,String) --- An encoding scheme for a HTML form. formEnc :: String -> FormParam formEnc enc = FormEnc enc --- A URL for a CSS file for a HTML form. formCSS :: String -> FormParam formCSS css = FormCSS css --- Meta information for a HTML form. The argument is a list of --- attributes included in the `meta`-tag in the header for this form. formMetaInfo :: [(String,String)] -> FormParam formMetaInfo attrs = FormMeta attrs --- Optional attribute for the body element of the HTML form. --- More than one occurrence is allowed, i.e., all such attributes are --- collected. formBodyAttr :: (String,String) -> FormParam formBodyAttr attr = BodyAttr attr --- A cookie to be sent to the client's browser when a HTML form is --- requested. formCookie :: (String,String) -> FormParam formCookie (n,v) = FormCookie n v [] --- The possible parameters of a cookie. data CookieParam = CookieExpire ClockTime | CookieDomain String | CookiePath String | CookieSecure --- A basic HTML form for active web pages with the default encoding --- and a default background. --- @param title - the title of the form --- @param hexps - the form's body (list of HTML expressions) --- @return an HTML form form :: String -> [HtmlExp] -> HtmlForm form title hexps = HtmlForm title [] hexps --- A standard HTML form for active web pages where the title is included --- in the body as the first header. --- @param title - the title of the form --- @param hexps - the form's body (list of HTML expressions) --- @return an HTML form with the title as the first header standardForm :: String -> [HtmlExp] -> HtmlForm standardForm title hexps = form title (h1 [htxt title] : hexps) --- An HTML form with simple cookies. --- The cookies are sent to the client's browser together with this form. --- @param title - the title of the form --- @param cookies - the cookies as a list of name/value pairs --- @param hexps - the form's body (list of HTML expressions) --- @return an HTML form cookieForm :: String -> [(String,String)] -> [HtmlExp] -> HtmlForm cookieForm t cs he = HtmlForm t (map (\(n,v)->FormCookie n v []) cs) he --- Add simple cookie to HTML form. --- The cookies are sent to the client's browser together with this form. --- @param cs - the cookies as a list of name/value pairs --- @param form - the form to add cookies to --- @return a new HTML form addCookies :: [(String,String)] -> HtmlForm -> HtmlForm addCookies cs (HtmlForm t fas hs) = HtmlForm t (map (\ (n,v) -> FormCookie n v []) cs ++ fas) hs addCookies _ (HtmlAnswer _ _) = error "addCookies: cannot add cookie to Html answer" -- Shows the cookie in standard syntax: formatCookie :: (String,String,[CookieParam]) -> String formatCookie (name,value,params) = "Set-Cookie: " ++ name ++ "=" ++ string2urlencoded value ++ concatMap (\p->"; "++formatCookieParam p) params -- Formats a cookie parameter: formatCookieParam :: CookieParam -> String formatCookieParam (CookieExpire e) = "expires=" ++ toCookieDateString e formatCookieParam (CookieDomain d) = "domain=" ++ d formatCookieParam (CookiePath p) = "path=" ++ p formatCookieParam CookieSecure = "secure" -- Formats a clock time into a date string for cookies: toCookieDateString :: ClockTime -> String toCookieDateString time = let (CalendarTime y mo d h mi s tz) = toUTCTime time in (show d ++ "-" ++ shortMonths!!(mo-1) ++ "-" ++ show y ++ " " ++ toTimeString (CalendarTime y mo d h mi s tz) ++ " UTC") where shortMonths = ["Jan","Feb","Mar","Apr","May","Jun", "Jul","Aug","Sep","Oct","Nov","Dec"] --- A textual result instead of an HTML form as a result for active web pages. --- @param txt - the contents of the result page --- @return an HTML answer form answerText :: String -> HtmlForm answerText = HtmlAnswer "text/plain" --- A textual result instead of an HTML form as a result for active web pages --- where the encoding is given as the first parameter. --- @param enc - the encoding of the text(e.g., "utf-8" or "iso-8859-1") --- @param txt - the contents of the result page --- @return an HTML answer form answerEncText :: String -> String -> HtmlForm answerEncText enc = HtmlAnswer ("text/plain; charset="++enc) --- Adds a parameter to an HTML form. --- @param form - a form --- @param param - a form's parameter --- @return an HTML form addFormParam :: HtmlForm -> FormParam -> HtmlForm addFormParam (HtmlForm title params hexps) param = HtmlForm title (param:params) hexps addFormParam hexp@(HtmlAnswer _ _) _ = hexp addFormParams :: HtmlForm -> [FormParam] -> HtmlForm addFormParams hform [] = hform addFormParams hform (fp:fps) = addFormParams (hform `addFormParam` fp) fps --- Adds redirection to given HTML form. --- @param secs - Number of seconds to wait before executing autromatic redirection --- @param url - The URL whereto redirect to --- @param form - The form to add the header information to redirect :: Int -> String -> HtmlForm -> HtmlForm redirect secs url hform = hform `addFormParam` HeadInclude (HtmlStruct "meta" [("http-equiv","refresh"), ("content",show secs++"; URL="++url)] []) --- Adds expire time to given HTML form. --- @param secs - Number of seconds before document expires --- @param form - The form to add the header information to expires :: Int -> HtmlForm -> HtmlForm expires secs hform = hform `addFormParam` HeadInclude (HtmlStruct "meta" [("http-equiv","expires"), ("content",show secs)] []) --- Adds sound to given HTML form. The functions adds two different declarations --- for sound, one invented by Microsoft for the internet explorer, one introduced --- for netscape. As neither is an official part of HTML, addsound might not work --- on all systems and browsers. The greatest chance is by using sound files --- in MID-format. --- @param soundfile - Name of file containing the sound to be played --- @param loop - Should sound go on infinitely? Use with care. --- @param form - The form to add sound to addSound :: String -> Bool -> HtmlForm -> HtmlForm addSound soundfile loop (HtmlForm title params conts) = HtmlForm title (HeadInclude (HtmlStruct "bgsound" [("src",soundfile), ("loop",if loop then "infinite" else "1")] []):params) (HtmlStruct "embed" ((if loop then [("loop","true")] else []) ++ [("src",soundfile),("autostart","true"), ("hidden","true"), ("height","0"), ("width","0")]) []: conts) addSound _ _ (HtmlAnswer _ _) = error "HTML.addSound: unable to add sound to general HTML Answer" ------------------------------------------------------------------------------ --- The data type for representing HTML pages. --- The constructor arguments are the title, the parameters, and --- the contents (body) of the web page. data HtmlPage = HtmlPage String [PageParam] [HtmlExp] --- The possible parameters of an HTML page. --- @cons PageEnc - the encoding scheme of this page --- @cons PageCSS s - a URL for a CSS file for this page --- @cons PageJScript s - a URL for a Javascript file for this page --- @cons PageMeta as - meta information (in form of attributes) for this page --- @cons PageLink as - link information (in form of attributes) for this page --- @cons PageBodyAttr attr - optional attribute for the body element of the --- page (more than one occurrence is allowed) data PageParam = PageEnc String | PageCSS String | PageJScript String | PageMeta [(String,String)] | PageLink [(String,String)] | PageBodyAttr (String,String) --- An encoding scheme for a HTML page. pageEnc :: String -> PageParam pageEnc enc = PageEnc enc --- A URL for a CSS file for a HTML page. pageCSS :: String -> PageParam pageCSS css = PageCSS css --- Meta information for a HTML page. The argument is a list of --- attributes included in the `meta`-tag in the header for this page. pageMetaInfo :: [(String,String)] -> PageParam pageMetaInfo attrs = PageMeta attrs --- Link information for a HTML page. The argument is a list of --- attributes included in the `link`-tag in the header for this page. pageLinkInfo :: [(String,String)] -> PageParam pageLinkInfo attrs = PageLink attrs --- Optional attribute for the body element of the web page. --- More than one occurrence is allowed, i.e., all such attributes are --- collected. pageBodyAttr :: (String,String) -> PageParam pageBodyAttr attr = PageBodyAttr attr --- A basic HTML web page with the default encoding. --- @param title - the title of the page --- @param hexps - the page's body (list of HTML expressions) --- @return an HTML page page :: String -> [HtmlExp] -> HtmlPage page title hexps = HtmlPage title [PageEnc defaultEncoding] hexps --- A standard HTML web page where the title is included --- in the body as the first header. --- @param title - the title of the page --- @param hexps - the page's body (list of HTML expressions) --- @return an HTML page with the title as the first header standardPage :: String -> [HtmlExp] -> HtmlPage standardPage title hexps = page title (h1 [htxt title] : hexps) --- Adds a parameter to an HTML page. --- @param form - a page --- @param param - a page's parameter --- @return an HTML page addPageParam :: HtmlPage -> PageParam -> HtmlPage addPageParam (HtmlPage title params hexps) param = HtmlPage title (param:params) hexps ------------------------------------------------------------------------------ -- some useful abbreviations: --- Basic text as HTML expression. --- The text may contain special HTML chars (like <,>,&,") --- which will be quoted so that they appear as in the parameter string. htxt :: String -> HtmlExp htxt s = HtmlText (htmlQuote s) --- A list of strings represented as a list of HTML expressions. --- The strings may contain special HTML chars that will be quoted. htxts :: [String] -> [HtmlExp] htxts = map htxt --- An empty HTML expression. hempty :: HtmlExp hempty = HtmlText "" --- Non breaking Space nbsp :: HtmlExp nbsp = HtmlText " " --- Header 1 h1 :: [HtmlExp] -> HtmlExp h1 hexps = HtmlStruct "h1" [] hexps --- Header 2 h2 :: [HtmlExp] -> HtmlExp h2 hexps = HtmlStruct "h2" [] hexps --- Header 3 h3 :: [HtmlExp] -> HtmlExp h3 hexps = HtmlStruct "h3" [] hexps --- Header 4 h4 :: [HtmlExp] -> HtmlExp h4 hexps = HtmlStruct "h4" [] hexps --- Header 5 h5 :: [HtmlExp] -> HtmlExp h5 hexps = HtmlStruct "h5" [] hexps --- Paragraph par :: [HtmlExp] -> HtmlExp par hexps = HtmlStruct "p" [] hexps --- Section section :: [HtmlExp] -> HtmlExp section hexps = HtmlStruct "section" [] hexps --- Header header :: [HtmlExp] -> HtmlExp header hexps = HtmlStruct "header" [] hexps --- Footer footer :: [HtmlExp] -> HtmlExp footer hexps = HtmlStruct "footer" [] hexps --- Emphasize emphasize :: [HtmlExp] -> HtmlExp emphasize hexps = HtmlStruct "em" [] hexps --- Strong (more emphasized) text. strong :: [HtmlExp] -> HtmlExp strong hexps = HtmlStruct "strong" [] hexps --- Boldface bold :: [HtmlExp] -> HtmlExp bold hexps = HtmlStruct "b" [] hexps --- Italic italic :: [HtmlExp] -> HtmlExp italic hexps = HtmlStruct "i" [] hexps --- Navigation nav :: [HtmlExp] -> HtmlExp nav doc = HtmlStruct "nav" [] doc --- Program code code :: [HtmlExp] -> HtmlExp code hexps = HtmlStruct "code" [] hexps --- Centered text center :: [HtmlExp] -> HtmlExp center hexps = HtmlStruct "center" [] hexps --- Blinking text blink :: [HtmlExp] -> HtmlExp blink hexps = HtmlStruct "blink" [] hexps --- Teletype font teletype :: [HtmlExp] -> HtmlExp teletype hexps = HtmlStruct "tt" [] hexps --- Unformatted input, i.e., keep spaces and line breaks and --- don't quote special characters. pre :: [HtmlExp] -> HtmlExp pre hexps = HtmlStruct "pre" [] hexps --- Verbatim (unformatted), special characters (<,>,&,") --- are quoted. verbatim :: String -> HtmlExp verbatim s = HtmlStruct "pre" [] [HtmlText (htmlQuote s)] --- Address address :: [HtmlExp] -> HtmlExp address hexps = HtmlStruct "address" [] hexps --- Hypertext reference href :: String -> [HtmlExp] -> HtmlExp href ref hexps = HtmlStruct "a" [("href",ref)] hexps --- An anchored text with a hypertext reference inside a document. anchor :: String -> [HtmlExp] -> HtmlExp anchor anc hexps = HtmlStruct "span" [("id",anc)] hexps --- Unordered list --- @param items - the list items where each item is a list of HTML expressions ulist :: [[HtmlExp]] -> HtmlExp ulist items = HtmlStruct "ul" [] (map litem items) --- Ordered list --- @param items - the list items where each item is a list of HTML expressions olist :: [[HtmlExp]] -> HtmlExp olist items = HtmlStruct "ol" [] (map litem items) --- A single list item (usually not explicitly used) litem :: [HtmlExp] -> HtmlExp litem hexps = HtmlStruct "li" [] hexps --- Description list --- @param items - a list of (title/description) pairs (of HTML expressions) dlist :: [([HtmlExp],[HtmlExp])] -> HtmlExp dlist items = HtmlStruct "dl" [] (concatMap ditem items) where ditem (hexps1,hexps2) = [HtmlStruct "dt" [] hexps1, HtmlStruct "dd" [] hexps2] --- Table with a matrix of items where each item is a list of HTML expressions. table :: [[[HtmlExp]]] -> HtmlExp table items = HtmlStruct "table" [] (map (\row->HtmlStruct "tr" [] (map (\item -> HtmlStruct "td" [] item) row)) items) --- Similar to table but introduces header tags for the first row. headedTable :: [[[HtmlExp]]] -> HtmlExp headedTable = withinTable . table where withinTable (HtmlStruct "table" attrs (HtmlStruct "tr" rowAttrs row:rows)) = HtmlStruct "table" attrs (HtmlStruct "tr" rowAttrs (map addTh row):rows) addTh x = case x of (HtmlStruct "td" attrs conts) -> HtmlStruct "th" attrs conts other -> other --- Add a row of items (where each item is a list of HTML expressions) --- as headings to a table. If the first argument is not a table, --- the headings are ignored. addHeadings :: HtmlExp -> [[HtmlExp]] -> HtmlExp addHeadings htable headings = case htable of HtmlStruct "table" attrs rows -> HtmlStruct "table" attrs (HtmlStruct "tr" [] (map (\item->HtmlStruct "th" [] item) headings):rows) _ -> htable --- Horizontal rule hrule :: HtmlExp hrule = HtmlStruct "hr" [] [] --- Break a line breakline :: HtmlExp breakline = HtmlStruct "br" [] [] --- Image --- @param src - the URL of the image --- @param alt - the alternative text shown instead of the image image :: String -> String -> HtmlExp image src alt = HtmlStruct "img" [("src",src),("alt",htmlQuote alt)] [] -------------- styles and document structuring: --- Defines a style sheet to be used in this HTML document. --- @param css - a string in CSS format styleSheet :: String -> HtmlExp styleSheet css = HtmlStruct "style" [("type","text/css")] [HtmlText css] --- Provides a style for HTML elements. --- The style argument is the name of a style class defined in a --- style definition (see styleSheet) or in an --- external style sheet (see form and page parameters FormCSS --- and PageCSS). --- @param st - name of a style class --- @param hexps - list of HTML expressions style :: String -> [HtmlExp] -> HtmlExp style st hexps = HtmlStruct "span" [("class",st)] hexps --- Provides a style for a basic text. --- The style argument is the name of a style class defined in an --- external style sheet. --- @param st - name of a style class --- @param txt - a string (special characters will be quoted) textstyle :: String -> String -> HtmlExp textstyle st txt = HtmlStruct "span" [("class",st)] [htxt txt] --- Provides a style for a block of HTML elements. --- The style argument is the name of a style class defined in an --- external style sheet. This element is used (in contrast to "style") --- for larger blocks of HTML elements since a line break is placed --- before and after these elements. --- @param st - name of a style class --- @param hexps - list of HTML expressions blockstyle :: String -> [HtmlExp] -> HtmlExp blockstyle st hexps = HtmlStruct "div" [("class",st)] hexps --- Joins a list of HTML elements into a single HTML element. --- Although this construction has no rendering, it is sometimes useful --- for programming when several HTML elements must be put together. --- @param hexps - list of HTML expressions inline :: [HtmlExp] -> HtmlExp inline hexps = HtmlStruct "span" [] hexps --- Joins a list of HTML elements into a block. --- A line break is placed before and after these elements. --- @param hexps - list of HTML expressions block :: [HtmlExp] -> HtmlExp block hexps = HtmlStruct "div" [] hexps -------------- forms and input fields: --- Submit button with a label string and an event handler button :: String -> HtmlHandler -> HtmlExp button label handler = HtmlEvent (HtmlStruct "input" [("type","submit"),("name","EVENT"), ("value",htmlQuote label)] []) handler --- Reset button with a label string resetbutton :: String -> HtmlExp resetbutton label = HtmlStruct "input" [("type","reset"),("value",htmlQuote label)] [] --- Submit button in form of an imag. --- @param src - url of the image --- @param handler - event handler imageButton :: String -> HtmlHandler -> HtmlExp imageButton src handler = HtmlEvent (HtmlStruct "input" [("type","image"),("name","EVENT"),("src",src)] []) handler --- Input text field with a reference and an initial contents textfield :: CgiRef -> String -> HtmlExp textfield cref contents | cref =:= CgiRef ref -- instantiate cref argument = HtmlCRef (HtmlStruct "input" [("type","text"),("name",ref), ("value",htmlQuote contents)] []) cref where ref free --- Input text field (where the entered text is obscured) with a reference password :: CgiRef -> HtmlExp password cref | cref =:= CgiRef ref -- instantiate cref argument = HtmlCRef (HtmlStruct "input" [("type","password"),("name",ref)] []) cref where ref free --- Input text area with a reference, height/width, and initial contents textarea :: CgiRef -> (Int,Int) -> String -> HtmlExp textarea cref (height,width) contents | cref =:= CgiRef ref -- instantiate cref argument = HtmlCRef (HtmlStruct "textarea" [("name",ref), ("rows",show height),("cols",show width)] [htxt contents]) cref where ref free --- A checkbox with a reference and a value. --- The value is returned if checkbox is on, otherwise "" is returned. checkbox :: CgiRef -> String -> HtmlExp checkbox cref value | cref =:= CgiRef ref -- instantiate cref argument = HtmlCRef (HtmlStruct "input" [("type","checkbox"),("name",ref), ("value",htmlQuote value)] []) cref where ref free --- A checkbox that is initially checked with a reference and a value. --- The value is returned if checkbox is on, otherwise "" is returned. checkedbox :: CgiRef -> String -> HtmlExp checkedbox cref value | cref =:= CgiRef ref -- instantiate cref argument = HtmlCRef (HtmlStruct "input" [("type","checkbox"),("name",ref), ("value",htmlQuote value),("checked","checked")] []) cref where ref free --- A main button of a radio (initially "on") with a reference and a value. --- The value is returned of this button is on. --- A complete radio button suite always consists of a main button --- (radio_main) and some further buttons (radio_others) with the --- same reference. Initially, the main button is selected --- (or nothing is selected if one uses radio_main_off instead of radio_main). --- The user can select another button but always at most one button --- of the radio can be selected. The value corresponding to the --- selected button is returned in the environment for this radio reference. radio_main :: CgiRef -> String -> HtmlExp radio_main cref value | cref =:= CgiRef ref -- instantiate cref argument = HtmlCRef (HtmlStruct "input" [("type","radio"),("name",ref), ("value",htmlQuote value),("checked","yes")] []) cref where ref free --- A main button of a radio (initially "off") with a reference and a value. --- The value is returned of this button is on. radio_main_off :: CgiRef -> String -> HtmlExp radio_main_off cref value | cref =:= CgiRef ref -- instantiate cref argument = HtmlCRef (HtmlStruct "input" [("type","radio"),("name",ref), ("value",htmlQuote value)] []) cref where ref free --- A further button of a radio (initially "off") with a reference (identical --- to the main button of this radio) and a value. --- The value is returned of this button is on. radio_other :: CgiRef -> String -> HtmlExp radio_other cref value | cref =:= CgiRef ref -- instantiate cref argument = HtmlStruct "input" [("type","radio"),("name",ref),("value",htmlQuote value)] [] where ref free --- A selection button with a reference and a list of name/value pairs. --- The names are shown in the selection and the value is returned --- for the selected name. selection :: CgiRef -> [(String,String)] -> HtmlExp selection cref menue | cref =:= CgiRef ref -- instantiate cref argument = HtmlCRef (HtmlStruct "select" [("name",ref)] ((concat . map (\(n,v)->[HtmlStruct "option" [("value",v)] [htxt n]])) menue)) cref where ref free --- A selection button with a reference, a list of name/value pairs, --- and a preselected item in this list. --- The names are shown in the selection and the value is returned --- for the selected name. --- @param ref - a CGI reference --- @param nvs - list of name/value pairs --- @param sel - the index of the initially selected item in the list nvs --- @return an HTML expression representing the selection button selectionInitial :: CgiRef -> [(String,String)] -> Int -> HtmlExp selectionInitial cref sellist sel | cref =:= CgiRef ref -- instantiate cref argument = HtmlCRef (HtmlStruct "select" [("name",ref)] (selOption sellist sel)) cref where ref free selOption [] _ = [] selOption ((n,v):nvs) i = HtmlStruct "option" ([("value",v)] ++ if i==0 then [("selected","selected")] else []) [htxt n] : selOption nvs (i-1) --- A selection button with a reference and a list of name/value/flag pairs. --- The names are shown in the selection and the value is returned --- if the corresponding name is selected. If flag is True, the --- corresonding name is initially selected. If more than one name --- has been selected, all values are returned in one string --- where the values are separated by newline (`'\n'`) characters. multipleSelection :: CgiRef -> [(String,String,Bool)] -> HtmlExp multipleSelection cref sellist | cref =:= CgiRef ref -- instantiate cref argument = HtmlCRef (HtmlStruct "select" [("name",ref),("multiple","multiple")] (map selOption sellist)) cref where ref free selOption (n,v,flag) = HtmlStruct "option" ([("value",v)] ++ if flag then [("selected","selected")] else []) [htxt n] --- A hidden field to pass a value referenced by a fixed name. --- This function should be used with care since it may cause --- conflicts with the CGI-based implementation of this library. hiddenfield :: String -> String -> HtmlExp hiddenfield name value = HtmlStruct "input" [("type","hidden"),("name",name),("value",value)] [] ------------------------------------------------------------------------------ --- Quotes special characters (`<`,`>`,`&`,`"`, umlauts) in a string --- as HTML special characters. htmlQuote :: String -> String htmlQuote [] = [] htmlQuote (c:cs) | c=='<' = "<" ++ htmlQuote cs | c=='>' = ">" ++ htmlQuote cs | c=='&' = "&" ++ htmlQuote cs | c=='"' = """ ++ htmlQuote cs | otherwise = htmlIsoUmlauts [c] ++ htmlQuote cs --- Translates umlauts in iso-8859-1 encoding into HTML special characters. htmlIsoUmlauts :: String -> String htmlIsoUmlauts [] = [] htmlIsoUmlauts (c:cs) | oc==228 = "ä" ++ htmlIsoUmlauts cs | oc==246 = "ö" ++ htmlIsoUmlauts cs | oc==252 = "ü" ++ htmlIsoUmlauts cs | oc==196 = "Ä" ++ htmlIsoUmlauts cs | oc==214 = "Ö" ++ htmlIsoUmlauts cs | oc==220 = "Ü" ++ htmlIsoUmlauts cs | oc==223 = "ß" ++ htmlIsoUmlauts cs | oc==197 = "Å" ++ htmlIsoUmlauts cs | oc==250 = "ú"++ htmlIsoUmlauts cs | oc==237 = "í"++ htmlIsoUmlauts cs | oc==225 = "á"++ htmlIsoUmlauts cs | otherwise = c : htmlIsoUmlauts cs where oc = ord c ------------------------------------------------------------------------------ --- Adds an attribute (name/value pair) to an HTML element. addAttr :: HtmlExp -> (String,String) -> HtmlExp addAttr hexp attr = addAttrs hexp [attr] --- Adds a list of attributes (name/value pair) to an HTML element. addAttrs :: HtmlExp -> [(String,String)] -> HtmlExp addAttrs (HtmlText s) _ = HtmlText s -- strings have no attributes addAttrs (HtmlStruct tag attrs hexps) newattrs = HtmlStruct tag (attrs++newattrs) hexps addAttrs (HtmlEvent hexp handler) attrs = HtmlEvent (addAttrs hexp attrs) handler addAttrs (HtmlCRef hexp cref) attrs = HtmlCRef (addAttrs hexp attrs) cref --- Adds a class attribute to an HTML element. addClass :: HtmlExp -> String -> HtmlExp addClass hexp cls = addAttr hexp ("class",cls) ------------------------------------------------------------------------------ -- Auxiliaries for faster show (could be later put into a standard library) type ShowS = String -> String showString :: String -> String -> String showString s = (s++) showChar :: Char -> String -> String showChar c = (c:) nl :: String -> String nl = showChar '\n' concatS :: [a -> a] -> a -> a concatS [] = id concatS xs@(_:_) = foldr1 (\ f g -> f . g) xs ------------------------------------------------------------------------------ --- Transforms a list of HTML expressions into string representation. showHtmlExps :: [HtmlExp] -> String showHtmlExps hexps = showsHtmlExps 0 hexps "" -- get the string contents of an HTML expression: getText :: HtmlExp -> String getText (HtmlText s) = s getText (HtmlStruct _ _ _) = "" getText (HtmlEvent he _) = getText he getText (HtmlCRef he _) = getText he -- get the (last) tag of an HTML expression: getTag :: HtmlExp -> String getTag (HtmlText _) = "" getTag (HtmlStruct tag _ _) = tag getTag (HtmlEvent he _) = getTag he getTag (HtmlCRef he _) = getTag he -- is this a tag where a line break can be safely added? tagWithLn :: String -> Bool tagWithLn t = t/="" && t `elem` ["br","p","li","ul","ol","dl","dt","dd","hr", "h1","h2","h3","h4","h5","h6","div", "html","title","head","body","link","meta","script", "form","table","tr","td"] --- Transforms a single HTML expression into string representation. showHtmlExp :: HtmlExp -> String showHtmlExp hexp = showsHtmlExp 0 hexp "" --- HTML tags that have no end tag in HTML: noEndTags :: [String] noEndTags = ["img","input","link","meta"] showsHtmlExp :: Int -> HtmlExp -> ShowS showsHtmlExp _ (HtmlText s) = showString s showsHtmlExp i (HtmlStruct tag attrs hexps) = let maybeLn j = if tagWithLn tag then nl . showTab j else id in maybeLn i . (if null hexps && (null attrs || tag `elem` noEndTags) then showsHtmlOpenTag tag attrs "/>" else showsHtmlOpenTag tag attrs ">" . maybeLn (i+2) . showExps hexps . maybeLn i . showString "' ) . maybeLn i where showExps = if tag=="pre" then concatS . map (showsHtmlExp 0) else showsHtmlExps (i+2) showsHtmlExp i (HtmlEvent hexp _) = showsHtmlExp i hexp showsHtmlExp i (HtmlCRef hexp _) = showsHtmlExp i hexp showsHtmlExps :: Int -> [HtmlExp] -> ShowS showsHtmlExps _ [] = id showsHtmlExps i (he:hes) = showsWithLnPrefix he . showsHtmlExps i hes where showsWithLnPrefix hexp = let s = getText hexp in if s/="" && isSpace (head s) then nl . showTab i . showString (tail s) else showsHtmlExp i hexp showTab :: Int -> String -> String showTab n = showString (take n (repeat ' ')) showsHtmlOpenTag :: String -> [(String,String)] -> String -> ShowS showsHtmlOpenTag tag attrs close = showChar '<' . showString tag . concatS (map attr2string attrs) . showString close where attr2string (attr,value) = showChar ' ' . showString attr . showString "=\"" . encodeQuotes value . showChar '"' -- encode double quotes as """: encodeQuotes [] = id encodeQuotes (c:cs) | c=='"' = showString """ . encodeQuotes cs | otherwise = showChar c . encodeQuotes cs ------------------------------------------------------------------------------ --- Transforms HTML page into string representation. --- @param page - the HTML page --- @return string representation of the HTML document showHtmlPage :: HtmlPage -> String showHtmlPage (HtmlPage title params html) = htmlPrelude ++ showHtmlExp (HtmlStruct "html" htmlTagAttrs [HtmlStruct "head" [] ([HtmlStruct "title" [] [HtmlText (htmlQuote title)]] ++ concatMap param2html params), HtmlStruct "body" bodyattrs html]) where param2html (PageEnc enc) = [HtmlStruct "meta" [("http-equiv","Content-Type"), ("content","text/html; charset="++enc)] []] param2html (PageCSS css) = [HtmlStruct "link" [("rel","stylesheet"),("type","text/css"),("href",css)] []] param2html (PageJScript js) = [HtmlStruct "script" [("type","text/javascript"),("src",js)] []] param2html (PageMeta attrs) = [HtmlStruct "meta" attrs []] param2html (PageLink attrs) = [HtmlStruct "link" attrs []] param2html (PageBodyAttr _) = [] -- these attributes are separately processed bodyattrs = [attr | (PageBodyAttr attr) <- params] --- Standard header for generated HTML pages. htmlPrelude :: String htmlPrelude = "\n" --- Standard attributes for element "html". htmlTagAttrs :: [(String,String)] htmlTagAttrs = [("lang","en")] ------------------------------------------------------------------------------ --- Gets the parameter attached to the URL of the script. --- For instance, if the script is called with URL --- "http://.../script.cgi?parameter", then "parameter" is --- returned by this I/O action. --- Note that an URL parameter should be "URL encoded" to avoid --- the appearance of characters with a special meaning. --- Use the functions "urlencoded2string" and "string2urlencoded" --- to decode and encode such parameters, respectively. getUrlParameter :: IO String getUrlParameter = getEnviron "QUERY_STRING" --- Translates urlencoded string into equivalent ASCII string. urlencoded2string :: String -> String urlencoded2string [] = [] urlencoded2string (c:cs) | c == '+' = ' ' : urlencoded2string cs | c == '%' = chr (maybe 0 fst (readHex (take 2 cs))) : urlencoded2string (drop 2 cs) | otherwise = c : urlencoded2string cs --- Translates arbitrary strings into equivalent urlencoded string. string2urlencoded :: String -> String string2urlencoded [] = [] string2urlencoded (c:cs) | isAlphaNum c = c : string2urlencoded cs | c == ' ' = '+' : string2urlencoded cs | otherwise = let oc = ord c in '%' : int2hex(oc `div` 16) : int2hex(oc `mod` 16) : string2urlencoded cs where int2hex i = if i<10 then chr (ord '0' + i) else chr (ord 'A' + i - 10) ------------------------------------------------------------------------------ --- Gets the cookies sent from the browser for the current CGI script. --- The cookies are represented in the form of name/value pairs since --- no other components are important here. getCookies :: IO [(String,String)] getCookies = do cookiestring <- getEnviron "HTTP_COOKIE" return $ parseCookies cookiestring -- translate a string of cookies (of the form "NAME1=VAL1; NAME2=VAL") -- into a list of name/value pairs: parseCookies :: String -> [(String,String)] parseCookies str = if str=="" then [] else let (c1,cs) = break (==';') str in parseCookie c1 : parseCookies (dropWhile (==' ') (if cs=="" then "" else tail cs)) where parseCookie s = let (name,evalue) = break (=='=') s in (name,if evalue=="" then "" else urlencoded2string (tail evalue)) --- For image buttons: retrieve the coordinates where the user clicked --- within the image. coordinates :: CgiEnv -> Maybe (Int,Int) coordinates env = let x = env (CgiRef "x") y = env (CgiRef "y") in if x/="" && y/="" then Just (tryReadNat 0 x, tryReadNat 0 y) else Nothing ------------------------------------------------------------------------------ --- The server implementing an HTML form (possibly containing input fields). --- It receives a message containing the environment of the client's --- web browser, translates the HTML form w.r.t. this environment --- into a string representation of the complete HTML document --- and sends the string representation back to the client's browser --- by binding the corresponding message argument. --- @param url - the URL of this executable. --- @param cgikey - a unique key to identify this CGI script (used for safe --- storing of event handlers in this server) --- @param hformact - an IO action returning an HTML form runFormServerWithKey :: String -> String -> IO HtmlForm -> IO () runFormServerWithKey url cgikey hformact = runFormServerWithKeyAndFormParams url cgikey [] hformact --- The server implementing an HTML form (possibly containing input fields). --- It receives a message containing the environment of the client's --- web browser, translates the HTML form w.r.t. this environment --- into a string representation of the complete HTML document --- and sends the string representation back to the client's browser --- by binding the corresponding message argument. --- @param url - the URL of this executable. --- @param cgikey - a unique key to identify this CGI script (used for safe --- storing of event handlers on the web server) --- @param formparams - form parameters added to the initial and all --- subsequent forms --- @param hformact - an IO action returning an HTML form runFormServerWithKeyAndFormParams :: String -> String -> [FormParam] -> IO HtmlForm -> IO () runFormServerWithKeyAndFormParams url cgikey formparams hformact = do args <- getArgs let (timeout,rargs) = stripTimeoutArg args case rargs of ["-port",port,"-scriptkey",skey] -> startCgiServer timeout port skey _ -> putErrLn $ "ERROR: cgi server called with illegal arguments" where stripTimeoutArg args = case args of ("-servertimeout":tos:rargs) -> (tryReadNat defaultCgiServerTimeout tos, rargs) _ -> (defaultCgiServerTimeout,args) startCgiServer timeout port scriptkey = do time <- getClockTime ltime <- toCalendarTime time (state,htmlstring) <- computeFormInStateAndEnv url cgikey formparams (initialServerState time) scriptkey hformact [] putStr htmlstring hClose stdout if isServerStateWithoutHandlers state then done else -- start server process: do let portname = port++scriptkey socket <- listenOn portname putErrLn $ calendarTimeToString ltime ++ ": server started on port " ++ portname registerCgiServer url portname serveCgiMessagesForForm timeout url cgikey portname formparams hformact socket state -- The default timeout period for the cgi server in milliseconds: defaultCgiServerTimeout :: Int defaultCgiServerTimeout = 7200000 -- two hours -- The main server loop: serveCgiMessagesForForm :: Int -> String -> String -> String -> [FormParam] -> IO HtmlForm -> Socket -> ServerState -> IO () serveCgiMessagesForForm servertimeout url cgikey portname fparams initform socket = serveCgiMessages where serveCgiMessages state = if isServerStateWithoutHandlers state then do -- terminate server due to inactivity ltime <- getLocalTime putErrLn $ calendarTimeToString ltime ++ ": terminated due to empty handler list" unregisterCgiServer portname sClose socket else waitForSocketAccept socket servertimeout >>= maybe (do -- terminate server due to inactivity ltime <- getLocalTime putErrLn $ calendarTimeToString ltime ++ ": terminated due to timeout" unregisterCgiServer portname sClose socket ) (\ (rhost,hdl) -> do hostname <- getHostname if rhost `elem` ["localhost","localhost.localdomain",hostname] || take 8 rhost == "127.0.0." then readCgiServerMsg hdl >>= maybe (hClose hdl >> serveCgiMessages state) (serveCgiMessage state hdl) else putErrLn ("Ignored message from: "++rhost) >> hClose hdl >> serveCgiMessages state ) -- Process the received CgiServerMsg: serveCgiMessage _ hdl StopCgiServer = do hClose hdl ltime <- getLocalTime putErrLn $ calendarTimeToString ltime ++ ": server terminated by stop message" unregisterCgiServer portname sClose socket serveCgiMessage state hdl CleanServer = do hClose hdl nstate <- cleanOldEventHandlers state serveCgiMessages nstate serveCgiMessage oldstate hdl GetLoad = do state <- cleanOldEventHandlers oldstate serverload <- getServerLoad state hPutStrLn hdl serverload hClose hdl serveCgiMessages state serveCgiMessage oldstate hdl SketchStatus = do state <- cleanOldEventHandlers oldstate serverstatus <- getServerStatus state hPutStrLn hdl serverstatus hClose hdl serveCgiMessages state serveCgiMessage state hdl SketchHandlers = reportStatus state hdl sketchEventHandler where sketchEventHandler (key,time,_,_,gkey) = do ltime <- toCalendarTime time return $ "No. " ++ show key ++ " (" ++ showGroupKey gkey ++ "), expires at: " ++ calendarTimeToString ltime ++ "\n" serveCgiMessage state hdl ShowStatus = reportStatus state hdl showEventHandler where showEventHandler (key,time,_,(_,_{-handler-}),gkey) = do ltime <- toCalendarTime time return $ "No. " ++ show key ++ " (" ++ showGroupKey gkey ++ "), expires at " ++ calendarTimeToString ltime ++ ": " ++ --showAnyQExpression handler ++ "\n" "\n" serveCgiMessage state hdl (CgiSubmit scriptenv formenv) = do let scriptkey = maybe "" id (lookup "SCRIPTKEY" scriptenv) mapIO_ (\(var,val) -> if var=="SCRIPTKEY" then done else setEnviron var val) scriptenv if null formenv -- initial form? then serveFormInEnv state scriptkey initform [] else do (rstate,mfe) <- getNextFormAndCgiEnv state cgikey formenv maybe (do urlparam <- getUrlParameter hPutStrLn hdl (noHandlerPage url urlparam) hClose hdl serveCgiMessages rstate) (\ (ioform,env) -> serveFormInEnv rstate scriptkey ioform env ) mfe where serveFormInEnv rstate scriptkey hformact cenv = do (nstate,htmlstring) <- computeFormInStateAndEnv url cgikey fparams rstate scriptkey hformact cenv hPutStrLn hdl htmlstring hClose hdl serveCgiMessages nstate reportStatus state@(stime,maxkey,ctime,ehs) hdl eh2string = do lstime <- toCalendarTime stime lctime <- toCalendarTime ctime ehsstrings <- mapIO eh2string ehs hPutStrLn hdl $ "Started at: " ++ calendarTimeToString lstime ++ "\n" ++ "Next cleanup: " ++ calendarTimeToString lctime ++ " (maxkey: " ++ show maxkey ++")\n"++ "Current event handlers:\n" ++ concat ehsstrings hClose hdl serveCgiMessages state -- computes a HTML form w.r.t. a state and a cgi environment: computeFormInStateAndEnv :: String -> String -> [FormParam] -> ServerState -> String -> IO HtmlForm -> [(String,String)] -> IO (ServerState,String) computeFormInStateAndEnv url cgikey fparams state scriptkey hformact cenv = catch tryComputeForm (\e -> do uparam <- getUrlParameter return (state,errorAsHtml e uparam)) where errorAsHtml e urlparam = addHtmlContentType $ showHtmlPage $ page "Server Error" [h1 [htxt "Error: Failure during computation"], par [htxt "Your request cannot be processed due to a run-time error:"], pre [htxt (showError e)], par [htxt "You can try to ", href (url ++ if null urlparam then "" else '?':urlparam) [htxt "click here"], htxt " to try again loading the web page or inform the web ", htxt "administrator about this problem."]] tryComputeForm = do cform <- hformact let (cookiestring,hform) = extractCookies cform (htmlstring,evhs) <- showAnswerFormInEnv url scriptkey (addFormParams hform fparams) (getMaxFieldNr cenv + 1) nstate <- storeEnvHandlers state (formWithMultipleHandlers hform) (encodeKey cgikey) (filter (\ (t,_) -> t/="DEFAULT" && take 6 t /= "EVENT_") cenv) evhs seq (isList htmlstring) done -- to ensure to catch all failures here return (nstate, cookiestring++htmlstring) isList [] = True isList (_:xs) = isList xs formWithMultipleHandlers :: HtmlForm -> Bool formWithMultipleHandlers (HtmlAnswer _ _) = False formWithMultipleHandlers (HtmlForm _ params _) = any isMultipleHandlers params where isMultipleHandlers formparam = case formparam of MultipleHandlers -> True _ -> False -- Encode an arbitrary string to make it less readable. -- Used for encoding CGI keys before storing them on the web server. encodeKey :: String -> String encodeKey = map mapchr . reverse . filter (not . isSpace) where mapchr c | oc<33 || oc>126 = c | oc<114 = chr (oc+13) | otherwise = chr (oc-81) where oc = ord c -- Puts a line to stderr: putErrLn :: String -> IO () putErrLn s = hPutStrLn stderr s >> hFlush stderr -------------------------------------------------------------------------- -- Auxiliaries to implement the cgi script server: -- get the next form and environment from a current environment (specifying a -- user-selected event handler) and a server state holding all event handlers: getNextFormAndCgiEnv :: ServerState -> String -> [(String,String)] -> IO (ServerState, Maybe (IO HtmlForm,[(String,String)])) getNextFormAndCgiEnv state cgikey newcenv = do (nstate,mbh) <- retrieveEnvHandlers state (encodeKey cgikey) (urlencoded2string (getFormEvent "" newcenv)) return $ maybe (nstate,Nothing) (\ (oldcenv,handler) -> let cenv = newcenv++oldcenv in (nstate, Just (handler (cgiGetValue cenv), cenv))) mbh -- put the HTML string corresponding to an HtmlForm with HTTP header on stdout: showAnswerFormInEnv :: String -> String -> HtmlForm -> Int -> IO (String,[(HtmlHandler,String)]) showAnswerFormInEnv url key hform@(HtmlForm _ _ _) crefnr = do (htmlstring,evhs) <- showHtmlFormInEnv url key hform crefnr return (addHtmlContentType htmlstring, evhs) showAnswerFormInEnv _ _ (HtmlAnswer ctype cont) _ = do return ("Content-Length: " ++ show (length cont) ++ "\nContent-Type: "++ctype++"\n\n"++cont, []) -- Adds the initial content lines (including content length) to an HTML string. addHtmlContentType :: String -> String addHtmlContentType htmlstring = "Content-Length: " ++ show (length htmlstring) ++ "\n" ++ "Content-Type: text/html\n\n" ++ htmlstring -- return the HTML string corresponding to an HtmlForm: showHtmlFormInEnv :: String -> String -> HtmlForm -> Int -> IO (String,[(HtmlHandler,String)]) showHtmlFormInEnv url key (HtmlForm ftitle fparams fhexp) crefnr = do qstr <- getEnviron "QUERY_STRING" --putStrLn (showHtmlExps [pre [par (env2html cenv),hrule]]) --debug (title,params,hexps,firsthandler,evhs) <- htmlForm2html (HtmlForm ftitle fparams fhexp) crefnr return (showForm (if null evhs then [] else [("SCRIPTKEY",key),("DEFAULT","EVENT_"++firsthandler)]) (if qstr=="" then url else url++"?"++qstr) (HtmlForm title params hexps), evhs) -- extract the cookies contained in a form and return the "set cookie" string -- and the form without the cookies: extractCookies :: HtmlForm -> (String,HtmlForm) extractCookies (HtmlAnswer ctype cont) = ("",HtmlAnswer ctype cont) extractCookies (HtmlForm title params hexp) = let cookiestring = if null cookies then "" else "Cache-control: no-cache=\"set-cookie\"\n" ++ concatMap ((++"\n") . formatCookie) cookies in (cookiestring, HtmlForm title otherparams hexp) where (cookies,otherparams) = splitFormParams params splitFormParams [] = ([],[]) splitFormParams (fparam:fps) = let (cs,ops) = splitFormParams fps in case fparam of FormCookie n v ps -> ((n,v,ps):cs,ops) _ -> (cs,fparam:ops) -- get the EVENT_ definition of the cgi environment -- (or "DEFAULT" value if it is not there): getFormEvent :: String -> [(String,String)] -> String getFormEvent deflt [] = deflt getFormEvent deflt ((tag,val):tvs) = if tag == "DEFAULT" then getFormEvent (drop 6 val) tvs else if take 6 tag == "EVENT_" then urlencoded2string (drop 6 tag) else getFormEvent deflt tvs -- compute the maximal field number of all "FIELD_nr" in a CGI environment: getMaxFieldNr :: [(String,String)] -> Int getMaxFieldNr [] = 0 getMaxFieldNr ((name,_):env) = if take 6 name == "FIELD_" then max (tryReadNat 0 (drop 6 name)) (getMaxFieldNr env) else getMaxFieldNr env -- try to read a natural number in a string or return first argument: tryReadNat :: Int -> String -> Int tryReadNat d s = maybe d (\(i,rs)->if null rs then i else d) (readNat s) -- get the value assigned to a name in a given cgi environment cgiGetValue :: [(String,String)] -> CgiRef -> String cgiGetValue cenv (CgiRef ref) = concat (intersperse "\n" (map snd (filter ((ref==) . fst) cenv))) -- transform HTML form into HTML document (by instantiating CgiRefs -- (starting with the second argument) and modifying event handlers): -- (Result: title/HTML document/form params/encoded first handler) htmlForm2html :: HtmlForm -> Int -> IO (String,[FormParam],[HtmlExp],String,[(HtmlHandler,String)]) htmlForm2html (HtmlForm title params html) crefnr = do let (htmlwithoutcrefs,newrefnr) = numberCgiRefs html crefnr -- enforce instantiation before handlers are stored: seq newrefnr done -- seq (normalForm htmlwithoutcrefs) done let (transhtml, evhs, fh) = translateHandlers htmlwithoutcrefs --storeEventHandlers cgikey oldcenv evhs return (title, params, transhtml, fh, evhs) -- instantiate all CgiRefs with a unique tag in HTML expressions: numberCgiRefs :: [HtmlExp] -> Int -> ([HtmlExp],Int) -- arguments: HTMLExps, number for cgi-refs -- result: translated HTMLExps, new number for cgi-refs numberCgiRefs [] i = ([],i) numberCgiRefs (HtmlText s : hexps) i = case numberCgiRefs hexps i of (nhexps,j) -> (HtmlText s : nhexps, j) numberCgiRefs (HtmlStruct tag attrs hexps1 : hexps2) i = case numberCgiRefs hexps1 i of (nhexps1,j) -> case numberCgiRefs hexps2 j of (nhexps2,k) -> (HtmlStruct tag attrs nhexps1 : nhexps2, k) numberCgiRefs (HtmlEvent (HtmlStruct tag attrs hes) handler : hexps) i = case numberCgiRefs hexps i of (nhexps,j) -> (HtmlEvent (HtmlStruct tag attrs hes) handler : nhexps, j) numberCgiRefs (HtmlCRef hexp (CgiRef ref) : hexps) i | ref =:= ("FIELD_"++show i) = case numberCgiRefs [hexp] (i+1) of ([nhexp],j) -> case numberCgiRefs hexps j of (nhexps,k) -> (nhexp : nhexps, k) -- translate all event handlers into their internal form: -- (assumption: all CgiRefs have already been instantiated and eliminated) -- the result is the translated HTML expression list (without HtmlEvents), -- the list of event handlers and their corresponding logical variables -- denoting the key that is inserted for the event handler in the translated -- HTML expression, and the string encoding of the first event handler -- (for the default handler) translateHandlers :: [HtmlExp] -> ([HtmlExp],[(HtmlHandler,String)],String) translateHandlers [] = ([],[],"") translateHandlers (HtmlText s : hexps) = let (nhexps,evhs,fh) = translateHandlers hexps in (HtmlText s : nhexps, evhs, fh) translateHandlers (HtmlStruct tag attrs hexps1 : hexps2) = let (nhexps1,evhs1,fh1) = translateHandlers hexps1 (nhexps2,evhs2,fh2) = translateHandlers hexps2 in (HtmlStruct tag attrs nhexps1 : nhexps2, evhs1++evhs2, if fh1=="" then fh2 else fh1) translateHandlers (HtmlEvent (HtmlStruct tag attrs hes) handler : hexps) = let (nhexps,evhs,_) = translateHandlers hexps fh = string2urlencoded key in (HtmlStruct tag (changeAssoc attrs "name" ("EVENT_" ++ fh)) hes : nhexps, (handler,key):evhs, fh) where key free -- show a HTML form in String representation: showForm :: [(String,String)] -> String -> HtmlForm -> String showForm cenv url (HtmlForm title params html) = htmlPrelude ++ showHtmlExp (HtmlStruct "html" htmlTagAttrs [HtmlStruct "head" [] ([HtmlStruct "title" [] [HtmlText (htmlQuote title)]] ++ concatMap param2html paramsWithEncoding), HtmlStruct "body" bodyattrs ((if null url || null cenv then id else \he->[HtmlStruct "form" ([("method","post"),("action",url)] ++ onsubmitattr ++ targetattr) he]) ( --[par (env2html cenv),hrule] ++ -- debug cenv2hidden cenv ++ html))]) where paramsWithEncoding = if null [e | (FormEnc e) <- params] then FormEnc defaultEncoding : params else params param2html (FormEnc enc) = [HtmlStruct "meta" [("http-equiv","Content-Type"), ("content","text/html; charset="++enc)] []] param2html (FormCSS css) = [HtmlStruct "link" [("rel","stylesheet"),("type","text/css"),("href",css)] []] param2html (FormMeta attrs) = [HtmlStruct "meta" attrs []] param2html (FormJScript js) = [HtmlStruct "script" [("type","text/javascript"),("src",js)] []] param2html (FormOnSubmit _) = [] param2html (FormTarget _) = [] -- no rule for FormCookie since they have been already processed param2html (HeadInclude hexp) = [hexp] param2html MultipleHandlers = [] param2html (BodyAttr _) = [] -- no rule for BodyAttr since it is considered later bodyattrs = [ps | (BodyAttr ps) <- params] onsubmit = [s | (FormOnSubmit s) <- params] onsubmitattr = if null onsubmit then [] else [("onsubmit",head onsubmit)] target = [s | (FormTarget s) <- params] targetattr = if null target then [] else [("target",head target)] -- translate cgi environment into HTML (for debugging purposes): env2html :: [(String,String)] -> [HtmlExp] env2html env = concat (map (\(n,v)->[htxt (n++": "++v),breakline]) env) -- translate environment into hidden fields (without EVENT field!): -- (note: the field values are urlencoded to avoid problems -- with passing special characters; moreover, the names of fields -- containing urlencoded values are prefixed by "U") cenv2hidden :: [(String,String)] -> [HtmlExp] cenv2hidden env = concat (map pair2hidden env) where pair2hidden (n,v) | take 6 n == "EVENT_" = [] | take 6 n == "FIELD_" = [hiddenfield ('U':n) (string2urlencoded v)] | otherwise = [hiddenfield n v] ------------------------------------------------------------------------------ -- association lists (list of tag/value pairs): -- change an associated value (or add association, if not there): changeAssoc :: [(tt,tv)] -> tt -> tv -> [(tt,tv)] changeAssoc [] tag val = [(tag,val)] changeAssoc ((tag1,val1):tvs) tag val = if tag1 == tag then (tag,val) : tvs else (tag1,val1) : changeAssoc tvs tag val ------------------------------------------------------------------------------ --- Transforms HTML expressions into LaTeX string representation. showLatexExps :: [HtmlExp] -> String showLatexExps hexps = concat (map showLatexExp hexps) --- Transforms an HTML expression into LaTeX string representation. showLatexExp :: HtmlExp -> String showLatexExp (HtmlText s) = "{" ++ specialchars2tex s ++ "}" showLatexExp (HtmlStruct tag attrs htmlexp) | tag=="html" = showLatexExps htmlexp | tag=="head" = "" -- ignore header | tag=="body" = showLatexExps htmlexp | tag=="form" = showLatexExps htmlexp | tag=="h1" = "\\section*{" ++ showLatexExps htmlexp ++ "}\n" | tag=="h2" = "\\subsection*{" ++ showLatexExps htmlexp ++ "}\n" | tag=="h3" = "\\subsubsection*{" ++ showLatexExps htmlexp ++ "}\n" | tag=="h4" = "\\paragraph*{" ++ showLatexExps htmlexp ++ "}\n" | tag=="h5" = "\\subparagraph*{" ++ showLatexExps htmlexp ++ "}\n" | tag=="p" = showLatexExps htmlexp ++ "\\par\n" | tag=="b" = "{\\bf " ++ showLatexExps htmlexp ++ "}" | tag=="em" = "\\emph{" ++ showLatexExps htmlexp ++ "}" | tag=="i" = "{\\it " ++ showLatexExps htmlexp ++ "}" | tag=="tt" = "{\\tt " ++ showLatexExps htmlexp ++ "}" | tag=="code" = "{\\tt " ++ showLatexExps htmlexp ++ "}" | tag=="center" = latexEnvironment "center" (showLatexExps htmlexp) | tag=="pre" = latexEnvironment "verbatim" (textOf htmlexp) | tag=="font" = showLatexExps htmlexp -- ignore font changes | tag=="address" = showLatexExps htmlexp | tag=="blink" = showLatexExps htmlexp | tag=="sub" = "$_{\\mbox{" ++ showLatexExps htmlexp ++ "}}$" | tag=="sup" = "$^{\\mbox{" ++ showLatexExps htmlexp ++ "}}$" | tag=="a" = showLatexExps htmlexp ++ -- add href attribute as footnote, if present: maybe "" (\url->"\\footnote{\\tt "++specialchars2tex url++"}\n") (findHtmlAttr "href" attrs) | tag=="ul" = latexEnvironment "itemize" (showLatexExps htmlexp) | tag=="ol" = latexEnvironment "enumerate" (showLatexExps htmlexp) | tag=="li" = "\\item\n" ++ showLatexExps htmlexp ++ "\n" | tag=="dl" = latexEnvironment "description" (showLatexExps htmlexp) | tag=="dt" = "\\item[" ++ showLatexExps htmlexp ++ "]~\\\\\n" | tag=="dd" = showLatexExps htmlexp -- tables will be set using the longtable environment, -- (The package longtable is added by default to every latex document) | tag=="table" = attrLatexEnv "longtable" (latexTabFormat htmlexp) (showLatexTableContents htmlexp) | tag=="tr" = let cells = map showLatexExp htmlexp in concat (intersperse " & " cells) ++ "\\\\\n" | tag=="td" = showLatexExps htmlexp | tag=="br" = "\\par\n" | tag=="hr" = "\\vspace{2ex}\\hrule\n" | tag=="img" = "{" ++ maybe "{\\tt}" specialchars2tex (findHtmlAttr "alt" attrs) ++ "}" | tag=="input" && maybe "" id (findHtmlAttr "type" attrs) == "hidden" = "" | otherwise = "{\\tt<"++tag++">}" ++ showLatexExps htmlexp ++ "{\\tt}" -- create latex environment of name "env" with content "content" latexEnvironment :: String -> String -> String latexEnvironment env content = attrLatexEnv env "" content -- create latex environment of name "env" with content "content" -- adding the parameters "attr" attrLatexEnv :: String -> String -> String -> String attrLatexEnv env attr content = "\\begin{"++env++"}"++attr++"\n" ++content ++"\n\\end{"++env++"}\n" -- yield the format of a table, e.g. {lll} from list of html rows. -- for longtables we set the chunksize big enough -- to avoid having to rerun latex for inaccurat tables. latexTabFormat :: [HtmlExp] -> String latexTabFormat rows = "{" ++ replicate breadth 'l' ++ "}" ++ "\\setcounter{LTchunksize}{"++show (length rows+5)++"}%" where breadth = foldl max 0 (map getBreadth rows) -- retrieve the breadth of an Html row getBreadth :: HtmlExp -> Int getBreadth row = case row of HtmlStruct "tr" _ tds -> length tds _ -> error "getBreadth: no row given" -- tranlate expressions inside tables showLatexTableContents :: [HtmlExp] -> String showLatexTableContents hexps = concatMap showLatexTableContent hexps -- tranlate expressions inside tables showLatexTableContent :: HtmlExp -> String showLatexTableContent (HtmlText s) = "{" ++ specialchars2tex s ++ "}" showLatexTableContent (HtmlStruct tag attrs htmlexp) | tag=="html" = showLatexTableContents htmlexp | tag=="head" = "" -- ignore header | tag=="body" = showLatexTableContents htmlexp | tag=="form" = showLatexTableContents htmlexp | tag=="p" = showLatexTableContents htmlexp ++ "\\par\n" | tag=="b" = "{\\bf " ++ showLatexTableContents htmlexp ++ "}" | tag=="em" = "\\emph{" ++ showLatexTableContents htmlexp ++ "}" | tag=="i" = "{\\it " ++ showLatexTableContents htmlexp ++ "}" | tag=="tt" = "{\\tt " ++ showLatexTableContents htmlexp ++ "}" | tag=="font" = showLatexTableContents htmlexp -- ignore font changes | tag=="address" = showLatexTableContents htmlexp | tag=="blink" = showLatexTableContents htmlexp | tag=="a" = showLatexTableContents htmlexp ++ -- add href attribute as footnote, if present: maybe "" (\url->"\\footnote{\\tt "++specialchars2tex url++"}\n") (findHtmlAttr "href" attrs) | tag=="tr" = let cells = map showLatexTableContent htmlexp in concat (intersperse " & " cells) ++ "\\\\\n" | tag=="td" = showLatexTableContents htmlexp | tag=="br" = "\\par\n" | tag=="hr" = "\\vspace{2ex}\\hrule\n" | tag=="img" = "{" ++ maybe "{\\tt}" specialchars2tex (findHtmlAttr "alt" attrs) ++ "}" | tag=="input" && maybe "" id (findHtmlAttr "type" attrs) == "hidden" = "" | otherwise = "{\\tt<"++tag++">}" ++ showLatexTableContents htmlexp ++ "{\\tt}" -- find a specific tag field in a list of HTML attributes: findHtmlAttr :: String -> [(String,String)] -> Maybe String findHtmlAttr _ [] = Nothing findHtmlAttr atag ((t,f):attrs) = if atag==t then Just f else findHtmlAttr atag attrs --- Convert special characters into TeX representation, if necessary. specialchars2tex :: String -> String specialchars2tex = htmlSpecialChars2tex . escapeLaTeXSpecials escapeLaTeXSpecials :: String -> String escapeLaTeXSpecials [] = [] escapeLaTeXSpecials (c:cs) | c=='^' = "{\\tt\\char94}" ++ escapeLaTeXSpecials cs | c=='~' = "{\\tt\\char126}" ++ escapeLaTeXSpecials cs | c=='\\' = "{\\textbackslash}" ++ escapeLaTeXSpecials cs | c=='<' = "{\\tt\\char60}" ++ escapeLaTeXSpecials cs | c=='>' = "{\\tt\\char62}" ++ escapeLaTeXSpecials cs | c=='_' = "\\_" ++ escapeLaTeXSpecials cs | c=='#' = "\\#" ++ escapeLaTeXSpecials cs | c=='$' = "\\$" ++ escapeLaTeXSpecials cs | c=='%' = "\\%" ++ escapeLaTeXSpecials cs | c=='{' = "\\{" ++ escapeLaTeXSpecials cs | c=='}' = "\\}" ++ escapeLaTeXSpecials cs | otherwise = c : escapeLaTeXSpecials cs --- Convert special HTML characters into their LaTeX representation, --- if necessary. htmlSpecialChars2tex :: String -> String htmlSpecialChars2tex [] = [] htmlSpecialChars2tex (c:cs) | c==chr 228 = "{\\\"a}" ++ htmlSpecialChars2tex cs | c==chr 246 = "{\\\"o}" ++ htmlSpecialChars2tex cs | c==chr 252 = "{\\\"u}" ++ htmlSpecialChars2tex cs | c==chr 196 = "{\\\"A}" ++ htmlSpecialChars2tex cs | c==chr 214 = "{\\\"O}" ++ htmlSpecialChars2tex cs | c==chr 220 = "{\\\"U}" ++ htmlSpecialChars2tex cs | c==chr 223 = "{\\ss}" ++ htmlSpecialChars2tex cs | c=='&' = let (special,rest) = break (==';') cs in if null rest then "\\&" ++ htmlSpecialChars2tex special -- wrong format else htmlspecial2tex special ++ htmlSpecialChars2tex (tail rest) | otherwise = c : htmlSpecialChars2tex cs htmlspecial2tex :: String -> String htmlspecial2tex special | special=="Auml" = "{\\\"A}" | special=="Euml" = "{\\\"E}" | special=="Iuml" = "{\\\"I}" | special=="Ouml" = "{\\\"O}" | special=="Uuml" = "{\\\"U}" | special=="auml" = "{\\\"a}" | special=="euml" = "{\\\"e}" | special=="iuml" = "{\\\"\\i}" | special=="ouml" = "{\\\"o}" | special=="uuml" = "{\\\"u}" | special=="szlig" = "{\\ss}" | special=="Aacute" = "{\\\'A}" | special=="Eacute" = "{\\\'E}" | special=="Iacute" = "{\\\'I}" | special=="Oacute" = "{\\\'O}" | special=="Uacute" = "{\\\'U}" | special=="aacute" = "{\\\'a}" | special=="eacute" = "{\\\'e}" | special=="iacute" = "{\\\'\\i}" | special=="oacute" = "{\\\'o}" | special=="uacute" = "{\\\'u}" | special=="Agrave" = "{\\`A}" | special=="Egrave" = "{\\`E}" | special=="Igrave" = "{\\`I}" | special=="Ograve" = "{\\`O}" | special=="Ugrave" = "{\\`U}" | special=="agrave" = "{\\`a}" | special=="egrave" = "{\\`e}" | special=="igrave" = "{\\`\\i}" | special=="ograve" = "{\\`o}" | special=="ugrave" = "{\\`u}" | special=="Acirc" = "{\\^A}" | special=="Ecirc" = "{\\^E}" | special=="Icirc" = "{\\^I}" | special=="Ocirc" = "{\\^O}" | special=="Ucirc" = "{\\^U}" | special=="acirc" = "{\\^a}" | special=="ecirc" = "{\\^e}" | special=="icirc" = "{\\^\\i}" | special=="ocirc" = "{\\^o}" | special=="ucirc" = "{\\^u}" | special=="Oslash" = "{\\O}" | special=="oslash" = "{\\o}" | special=="amp" = "{\\&}" | special=="ntilde" = "{\\~n}" | special=="otilde" = "{\\~o}" | special=="ccedil" = "{\\c{c}}" | special=="nbsp" = "~" | special=="quot" = "\"" | special=="lt" = "{$<$}" | special=="gt" = "{$>$}" | otherwise = "\\&"++special++";" ------------------------------------------------------------------------------ --- Transforms HTML expressions into a string representation of a complete --- LaTeX document. showLatexDoc :: [HtmlExp] -> String showLatexDoc htmlexps = showLatexDocs [htmlexps] --- Transforms HTML expressions into a string representation of a complete --- LaTeX document. --- The variable "packages" holds the packages to add to the latex document --- e.g. "ngerman" showLatexDocWithPackages :: [HtmlExp] -> [String] -> String showLatexDocWithPackages hexps packages = showLatexDocsWithPackages [hexps] packages --- Transforms a list of HTML expressions into a string representation --- of a complete LaTeX document where each list entry appears --- on a separate page. showLatexDocs :: [[HtmlExp]] -> String showLatexDocs htmlexps_list = showLatexDocsWithPackages htmlexps_list [] --- Transforms a list of HTML expressions into a string representation --- of a complete LaTeX document where each list entry appears --- on a separate page. --- The variable "packages" holds the packages to add to the latex document --- (e.g., "ngerman"). showLatexDocsWithPackages :: [[HtmlExp]] -> [String] -> String showLatexDocsWithPackages htmlexps_list packages = "\\documentclass[12pt]{article}\n"++ concatMap (\p->"\\usepackage{"++p++"}\n") packages++ -- Package longtable is added by default. "\\usepackage{longtable}"++ "\\nonstopmode\n"++ "\\setlength{\\topmargin}{ -1.5cm}\n"++ "\\setlength{\\oddsidemargin}{0.0cm}\n"++ "\\setlength{\\evensidemargin}{0.0cm}\n"++ "\\setlength{\\marginparwidth}{0.0cm}\n"++ "\\setlength{\\marginparsep}{0.0cm}\n"++ "\\setlength{\\textwidth}{16.5cm}\n"++ "\\setlength{\\textheight}{24.0cm}\n"++ "\\pagestyle{empty}\n"++ "\\begin{document}\n\\sloppy\n"++ "\\addtolength{\\baselineskip}{0.0ex}\n"++ "\\setlength{\\parindent}{0.0ex}\n"++ "\\addtolength{\\parskip}{0.5ex}\n"++ concat (intersperse "\\newpage\n" (map showLatexExps htmlexps_list))++ "\\end{document}\n" --- show german latex document germanLatexDoc :: [HtmlExp] -> String germanLatexDoc hexps = showLatexDocWithPackages hexps ["ngerman"] ------------------------------------------------------------------------------ --- Execute an HTML form in "interactive" mode. intForm :: IO HtmlForm -> IO () intForm = intFormMain "" "" "" "" False "" --intcgi = intFormMain "http://localhost/~mh/" "/home/mh/public_html/" "" "fwdcgienv.cgi" False "" --- Execute an HTML form in "interactive" mode with various parameters. --- @param baseurl - the base URL where this script is accessible for clients --- @param basecgi - the base directory in the local file system where --- this script should stored for execution --- @param reldir - the relative path added to baseurl and basecgi --- @param cginame - the name of the executable cgi script --- @param forever - True if the interactive execution should not be terminated --- when the final web page (without a handler) is shown --- @param urlparam - the URL parameter for the initial call to the cgi script --- @param hformact - IO action returning the HTML form intFormMain :: String -> String -> String -> String -> Bool -> String -> IO HtmlForm -> IO () intFormMain baseurl basecgi reldir cginame forever urlparam hformact = do pid <- getPID user <- getEnviron "USER" home <- getHomeDirectory let portname = "intcgi_" ++ show pid socket <- listenOn portname let cgiprogname = if null cginame then "cgitest_"++show pid++".cgi" else cginame url = (if null baseurl then "http://localhost/~"++user else baseurl) ++ "/" ++ reldir ++ "/" ++ cgiprogname cgifile = (if null basecgi then home++"/public_html/" else basecgi++"/")++ (if null reldir then "" else reldir ++"/") ++ cgiprogname cgikey = url++" 42" installShowCgiEnvScript portname cgifile setEnviron "QUERY_STRING" urlparam time <- getClockTime intFormInEnv url cgikey hformact hformact [] (initialServerState time) forever socket system ("rm "++cgifile) >> done intFormInEnv :: String -> String -> IO HtmlForm -> IO HtmlForm -> [(String,String)] -> ServerState -> Bool -> Socket -> IO () intFormInEnv url cgikey initform hformact cenv state forever socket = do if null cenv then putStrLn ">>> Start initial web form..." else done cform <- hformact let (cookiestring,hform) = extractCookies cform (htmlstring,evhs) <- showHtmlFormInEnv url "" (extendForm hform) (getMaxFieldNr cenv + 1) nstate <- storeEnvHandlers state (formWithMultipleHandlers hform) (encodeKey cgikey) (filter (\ (t,_) -> t/="DEFAULT" && take 6 t /= "EVENT_") cenv) evhs showHtmlStringInBrowser (cookiestring++htmlstring) if forever || formWithHandlers hform then do putStrLn ">>> Waiting for web page submission..." (_,hdl) <- socketAccept socket mbmsg <- readCgiServerMsg hdl maybe (intFormInEnv url cgikey initform hformact cenv state forever socket) (intFormProceed nstate hdl) mbmsg else putStrLn ">>> Final web page reached" where intFormProceed nstate hdl (CgiSubmit scriptenv newcenv) = do hPutStrLn hdl answerTxt hClose hdl mapIO_ (\ (var,val) -> setEnviron var val) scriptenv if null newcenv -- call to initial script? then intFormInEnv url cgikey initform initform [] nstate forever socket else do (rstate,mfe) <- getNextFormAndCgiEnv nstate cgikey newcenv maybe (putStrLn "ERROR: no submission handler") (\ (ioform,env) -> intFormInEnv url cgikey initform ioform env rstate forever socket) mfe answerTxt = "Content-Type: text/html\n\n" ++ showHtmlExp (italic [htxt "Waiting for next web form..."]) extendForm orgform = orgform `addFormParam` HeadInclude (HtmlStruct "base" [("href",url)] []) -- has an HTML form event handlers? formWithHandlers :: HtmlForm -> Bool formWithHandlers (HtmlForm _ _ hexps) = hasHandlers hexps where hasHandlers :: [HtmlExp] -> Bool hasHandlers [] = False hasHandlers (HtmlText _ : hes) = hasHandlers hes hasHandlers (HtmlStruct _ _ hes1 : hes2) = hasHandlers hes1 || hasHandlers hes2 hasHandlers (HtmlCRef he _ : hes) = hasHandlers [he] || hasHandlers hes hasHandlers (HtmlEvent _ _ : _) = True --- Shows a string in HTML format in a browser. showHtmlStringInBrowser :: String -> IO () showHtmlStringInBrowser htmlstring = do pid <- getPID let htmlfilename = "tmpcgiform_" ++ show pid ++ ".html" writeFile htmlfilename htmlstring system ("remote-netscape file:`pwd`/"++htmlfilename) done -- install web script that forward user inputs: installShowCgiEnvScript :: String -> String -> IO () installShowCgiEnvScript portname cgifile = do putStrLn ">>> Installing web script..." putStrLn $ "for port name: "++portname writeFile cgifile $ "#!/bin/sh\n"++ installDir++"/www/submitform \""++portname++"\"\n" system ("chmod 755 "++cgifile) done ------------------------------------------------------------------------------ -- The server for each dynamic web page manages the event handlers used in -- dynamic web pages on the server side. -- Each event handler is stored on the server side with a unique key. -- Only this key is sent in the actual web page to the client. -- Event handlers are only valid for a particular time period -- specified by eventHandlerExpiration, i.e., after that time -- event handlers will be deleted. -- The structure of the internal state of the server: -- Argument 1: Time when the server has been started. -- Argument 2: Current index for numbering new events -- Argument 3: Next date when cleanup is necessary -- Argument 4: The current event handlers -- (index,expiration date,cgikey,env,handler,groupindex) -- where groupindex is Nothing for handlers with multiple use -- and (Just gk) if the handlers should be deleted together -- with all other handlers having the same groupindex -- (usually, belonging to the same page) type ServerState = (ClockTime, Int, ClockTime, [(Int,ClockTime,String,([(String,String)],HtmlHandler),Maybe Int)]) --- Creates a new state for a server started at some time. initialServerState :: ClockTime -> ServerState initialServerState ctime = (ctime, 0, nextCleanup ctime, []) --- Is the list of event handlers of a server state empty? isServerStateWithoutHandlers :: ServerState -> Bool isServerStateWithoutHandlers (_,_,_,evhandlers) = null evhandlers --- Gets a string describing the load of the server process. --- If the server is "busy" it cannot accept further requests --- for initial web pages. getServerLoad :: ServerState -> IO String getServerLoad (stime,maxkey,_,evs) = do ctime <- getClockTime let busy = maxkey>500 || (compareClockTime ctime (addMinutes 30 stime) == GT) || null evs -- since a server without handlers will be terminated return (if busy then "busy" else "ready") --- Gets a string describing the status of the server process. getServerStatus :: ServerState -> IO String getServerStatus state@(stime,maxkey,_,evs) = do busy <- getServerLoad state lstime <- toCalendarTime stime pinfos <- getProcessInfos return $ "Status: " ++ busy ++ ", Maxkey: "++show maxkey ++ ", #Handlers: " ++ show (length evs) ++ ", Start time: " ++ calendarTimeToString lstime ++ "\n" ++ showMemInfo pinfos --- Shows the group key of a handler as a string. showGroupKey :: Maybe Int -> String showGroupKey Nothing = "multiple use" showGroupKey (Just gk) = "group " ++ show gk --- Stores a list of new event handlers for a given cgi program and --- the corresponding arguments with a new key. --- The second argument is True if the event handlers should only be used once. storeEnvHandlers :: ServerState -> Bool -> String -> [(String,String)] -> [(HtmlHandler,String)] -> IO ServerState storeEnvHandlers ostate multipleuse cgikey env handlerkeys = do time <- getClockTime cstate <- cleanOldEventHandlers ostate rannums <- getRandomSeed >>= return . drop 3 . nextInt let nstate = generateEventServerMessages rannums (if multipleuse then Nothing else Just (keyOfState cstate)) (eventHandlerExpiration time) cstate handlerkeys seq nstate done -- to ensure that handler keys are instantiated return nstate where generateEventServerMessages _ _ _ state [] = state generateEventServerMessages (rannum:rannums) groupkey expiredate state ((handler,hkey) : evhs) | hkey =:= show (keyOfState state) ++ ' ':showQTerm (toUTCTime expiredate) ++ '_' : show rannum -- add random element to handler key string = generateEventServerMessages rannums groupkey expiredate (storeNewEnvEventWithCgiKey groupkey expiredate state env handler) evhs keyOfState (_,key,_,_) = key storeNewEnvEventWithCgiKey groupkey date (stime,maxkey,cleandate,ehs) cenv info = (stime, if maxkey>30000 then 0 else maxkey+1, -- to avoid integer overflows cleandate, (maxkey,date,cgikey,(cenv,info),groupkey):ehs) -- clean event handlers that are too old: cleanOldEventHandlers :: ServerState -> IO ServerState cleanOldEventHandlers state@(_,_,_,[]) = return state cleanOldEventHandlers state@(stime,maxkey,cleandate,ehs@(_:_)) = do ctime <- getClockTime if compareClockTime ctime cleandate == LT then return state else do let currentehs = filter (isNotExpired ctime) ehs noehs = length ehs nocurrentehs = length currentehs if nocurrentehs < noehs then do -- report cleanup numbers: ltime <- toCalendarTime ctime putErrLn $ calendarTimeToString ltime ++ ": cleanup " ++ "(number of handlers: old = "++ show noehs ++ " / " ++ "current = "++ show nocurrentehs ++ ")" else done return (stime,maxkey, nextCleanup ctime, currentehs) where isNotExpired time (_,etime,_,_,_) = compareClockTime time etime == LT -- Retrieves a previously stored event handler for a cgi program. -- Returns Nothing if the handler is no longer available, i.e., expired. retrieveEnvHandlers :: ServerState -> String -> String -> IO (ServerState,Maybe ([(String,String)],HtmlHandler)) retrieveEnvHandlers state cgikey skey = let (numstring,datestring) = break (==' ') skey dateps = readsQTerm datestring num = tryReadNat (-1) numstring in if null datestring || null dateps || num < 0 then return (state,Nothing) else let (newstate,info) = getEnvEventWithCgiKey state num (fst (head dateps)) in seq newstate (return (newstate, info)) -- the "seq"s are put here and below to enfore the evaluation of the -- new state in order to avoid space leaks with old, unused handlers where getEnvEventWithCgiKey oldstate@(stime,maxkey,cleandate,ehs) key date = maybe (oldstate,Nothing) (\ (evhdlr,groupkey) -> maybe (oldstate, Just evhdlr) (\gk -> let newehs = deleteEv gk ehs in seq newehs ((stime,maxkey,cleandate,newehs), Just evhdlr)) groupkey ) (searchEv ehs) where -- search event handler searchEv [] = Nothing searchEv ((n,t,c,i,gk):es) = if key==n && date == toUTCTime t then if c==cgikey then Just (i,gk) else Nothing else searchEv es -- delete event handlers of the same group deleteEv _ [] = [] deleteEv groupkey (ev@(_,_,_,_,Nothing):es) = let des = deleteEv groupkey es in seq des (ev : des) deleteEv groupkey (ev@(_,_,_,_,Just gk):es) = if groupkey==gk then deleteEvInGroup groupkey es else let des = deleteEv groupkey es in seq des (ev : des) deleteEvInGroup _ [] = [] deleteEvInGroup _ (ev@(_,_,_,_,Nothing):es) = ev : es deleteEvInGroup groupkey (ev@(_,_,_,_,Just gk):es) = if groupkey==gk then deleteEvInGroup groupkey es else ev : es -- a new group has started so we stop the deletion -- Define for a given date a new date when the event handler expires. eventHandlerExpiration :: ClockTime -> ClockTime eventHandlerExpiration = addHours 1 --eventHandlerExpiration = addMinutes 1 -- Define for a given date a new date when the next cleanup of event handlers -- should be done. nextCleanup :: ClockTime -> ClockTime nextCleanup = addMinutes 5 --------------------------------------------------------------------------- curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/HtmlCgi.curry000066400000000000000000000434331305333611600236540ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library to support CGI programming in the HTML library. --- It is only intended as an auxiliary library to implement dynamic web --- pages according to the HTML library. --- It contains a simple script that is installed for a dynamic --- web page and which sends the user input to the real application --- server implementing the application. --- --- @author Michael Hanus --- @version September 2012 --- @category web ------------------------------------------------------------------------------ module HtmlCgi(CgiServerMsg(..),runCgiServerCmd, cgiServerRegistry,registerCgiServer,unregisterCgiServer, readCgiServerMsg,noHandlerPage,submitForm) where import System import Char import NamedSocket import CPNS(unregisterPort) import IO import IOExts(exclusiveIO,connectToCommand) import Directory(doesFileExist,getCurrentDirectory) import ReadNumeric import ReadShowTerm import Time import List -------------------------------------------------------------------------- -- Should the log messages of the server stored in a log file? withCgiLogging = True -------------------------------------------------------------------------- --- The messages to comunicate between the cgi script and the server program. --- CgiSubmit env cgienv nextpage - pass the environment and show next page, --- where env are the values of the environment variables of the web script --- (e.g., QUERY_STRING, REMOTE_HOST, REMOTE_ADDR), --- cgienv are the values in the current form submitted by the client, --- and nextpage is the answer text to be shown in the next web page --- @cons GetLoad - get info about the current load of the server process --- @cons SketchStatus - get a sketch of the status of the server --- @cons SketchHandlers - get a sketch of all event handlers of the server --- @cons ShowStatus - show the status of the server with all event handlers --- @cons CleanServer - clean up the server (with possible termination) --- @cons StopCgiServer - stop the server data CgiServerMsg = CgiSubmit [(String,String)] [(String,String)] | GetLoad | SketchStatus | SketchHandlers | ShowStatus | CleanServer | StopCgiServer --- Reads a line from a handle and check whether it is a syntactically --- correct cgi server message. readCgiServerMsg :: Handle -> IO (Maybe CgiServerMsg) readCgiServerMsg handle = do line <- hGetLine handle case readsQTerm line of [(msg,rem)] -> return (if all isSpace rem then Just msg else Nothing) _ -> return Nothing -------------------------------------------------------------------------- -- Main program to start a cgi script. It reads arguments and starts a small -- script to forward the arguments to a cgi server process. -- -- Optional script arguments: -- "-servertimeout n": The timeout period for the cgi server in milliseconds. -- If the cgi server process does not receive any request -- during this period, it will be terminated. -- The default value is defined in the library HTML. -- -- "-loadbalance ": specifies kind of load balancing (see makecurrycgi) -- Current possible values for : -- "no|standard|multiple" submitForm = do args <- getArgs let (serverargs,lb,rargs) = stripServerArgs "" NoBalance args case rargs of [url,cgikey,serverprog] -> cgiScript url serverargs lb (cgikey2portname cgikey) serverprog [portname] -> cgiInteractiveScript portname -- for interactive execution _ -> putStrLn $ "ERROR: cgi script called with illegal arguments!" where stripServerArgs serverargs load args = case args of ("-servertimeout":tos:rargs) -> stripServerArgs (" -servertimeout "++tos) load rargs ("-multipleservers":rargs) -> stripServerArgs serverargs Multiple rargs ("-loadbalance":lbt:rargs) -> stripServerArgs serverargs (if lbt=="no" then NoBalance else if lbt=="multiple" then Multiple else Standard) rargs _ -> (serverargs,load,args) -- load balance types: data LoadBalance = NoBalance | Standard | Multiple --- Executes a specific command for a cgi server. runCgiServerCmd :: String -> CgiServerMsg -> IO () runCgiServerCmd portname cmd = case cmd of StopCgiServer -> do putStrLn $ "Trying to stop server at port " ++ portname ++ "..." h <- trySendScriptServerMessage portname StopCgiServer hClose h unregisterPort portname CleanServer -> do putStrLn $ "Trying to clean server at port " ++ portname ++ "..." h <- trySendScriptServerMessage portname CleanServer hClose h GetLoad -> do -- for upward compatibility with previous implementations: h <- trySendScriptServerMessage portname GetLoad cs <- hGetContents h if length cs < 7 then do h' <- trySendScriptServerMessage portname SketchStatus copyOutputAndClose h' putChar '\n' else putStrLn cs ShowStatus -> do h <- trySendScriptServerMessage portname ShowStatus copyOutputAndClose h SketchStatus -> do h <- trySendScriptServerMessage portname SketchStatus copyOutputAndClose h SketchHandlers -> do -- for upward compatibility with previous implementations: lh <- trySendScriptServerMessage portname GetLoad cs <- hGetContents lh if length cs < 7 then do h <- trySendScriptServerMessage portname SketchHandlers copyOutputAndClose h else do h <- trySendScriptServerMessage portname SketchStatus copyOutputAndClose h _ -> error "HtmlCgi.runCgiServerCmd: called with illegal command!" --- Translates a cgi progname and key into a name for a port: cgikey2portname cgikey = concatMap (\c->if isAlphaNum c then [c] else []) cgikey -- Forward user inputs for interactive execution of cgi scripts: cgiInteractiveScript :: String -> IO () cgiInteractiveScript portname = do cgiServerEnvVals <- mapIO getEnviron cgiServerEnvVars let cgiServerEnv = zip cgiServerEnvVars cgiServerEnvVals formEnv <- getFormVariables catch (sendToServerAndPrintOrFail cgiServerEnv formEnv) (putStrLn . errorPage) where sendToServerAndPrintOrFail cgiEnviron newcenv = do h <- trySendScriptServerMessage portname (CgiSubmit cgiEnviron newcenv) copyOutputAndClose h errorPage e = "Content-type: text/html\n\n" ++ "\nServer Error\n" ++ "\n

Server Error

\n" ++ showError e ++ "\n" -- Forward user inputs to cgi server process: cgiScript :: String -> String -> LoadBalance -> String -> String -> IO () cgiScript url serverargs loadbalance portname serverprog = do cgiServerEnvVals <- mapIO getEnviron cgiServerEnvVars let cgiServerEnv = zip cgiServerEnvVars cgiServerEnvVals let urlparam = head cgiServerEnvVals formEnv <- getFormVariables if null formEnv then do -- call to initial script scriptKey <- if loadbalance==Multiple then getFreshKey else return "" catch (submitToServerOrStart url serverargs loadbalance portname scriptKey serverprog cgiServerEnv) (\_ -> putStrLn (noHandlerPage url urlparam)) else do -- call to continuation script let scriptKey = maybe "" id (lookup "SCRIPTKEY" formEnv) cgiEnviron = ("SCRIPTKEY",scriptKey) : cgiServerEnv newcenv = filter (\e -> fst e /= "SCRIPTKEY") formEnv catch (sendToServerAndPrintOrFail scriptKey cgiEnviron newcenv) (\_ -> putStrLn (noHandlerPage url urlparam)) where sendToServerAndPrintOrFail scriptKey cgiEnviron newcenv = do h <- trySendScriptServerMessage (portname++scriptKey) (CgiSubmit cgiEnviron newcenv) eof <- hIsEOF h if eof then error "Html.cgiScript: unexpected EOF failure" else copyOutputAndClose h -- get a new unique key for a script: getFreshKey :: IO String getFreshKey = do ctime <- getClockTime pid <- getPID return (show (clockTimeToInt ctime) ++ '_' : show pid) ------------------------------------------------------------------------ -- Generate HTML string of a web page with "no handler" error: noHandlerPage :: String -> String -> String noHandlerPage cgiurl urlparam = "Content-type: text/html\n\n" ++ "\nServer Error\n" ++ "\n

Error: no submission handler

\n" ++ "

Your request cannot be processed due to one of the following reasons:

\n" ++ "\n" ++ "

In any case, please click here to restart.

\n" ++ "\n" ------------------------------------------------------------------------ --- The values of the environment variables of the web script server --- that are transmitted to the application program. --- Currently, it contains only a selection of all reasonable variables --- but this list can be easily extended. cgiServerEnvVars = ["PATH_INFO","QUERY_STRING","HTTP_COOKIE","REMOTE_HOST","REMOTE_ADDR", "REQUEST_METHOD","SCRIPT_NAME","SERVER_NAME","SERVER_PORT"] -- The timeout (in msec) of the script server. -- If the port of the application server is not available within the timeout -- period, we assume that the application server does not exist and we start -- a new one. scriptServerTimeOut = 1000 -- send a message to the script server and return the connection handle, -- or fail: trySendScriptServerMessage :: String -> a -> IO Handle trySendScriptServerMessage portname msg = connectToSocketRepeat scriptServerTimeOut done 0 (portname++"@localhost") >>= maybe failed (\h -> hPutStrLn h (showQTerm msg) >> hFlush h >> return h) -- submit an initial web page request to a server or restart it: submitToServerOrStart url serverargs loadbalance pname scriptkey serverprog cgiServerEnv = connectToSocketRepeat scriptServerTimeOut done 0 completeportname >>= maybe (execAndCopyOutput servercmd) (\h -> if loadbalance/=Standard then cgiSubmit h else do isbusy <- getLoadOfServer h if isbusy then submitToOtherServer else connectToSocketRepeat scriptServerTimeOut done 0 completeportname >>= maybe (execAndCopyOutput servercmd) cgiSubmit ) where completeportname = pname++scriptkey++"@localhost" cmd = serverprog ++ serverargs ++ " -port \"" ++ pname ++ "\" -scriptkey \"" ++ scriptkey ++ "\"" errout = if withCgiLogging then " 2>> "++url++".log" else "" servercmd = cmd++errout++" &" cgiSubmit h = do let cgiEnviron = ("SCRIPTKEY",scriptkey) : cgiServerEnv hPutStrLn h (showQTerm (CgiSubmit cgiEnviron [])) hFlush h copyOutputAndClose h getLoadOfServer h = do hPutStrLn h (showQTerm GetLoad) hFlush h loadanswer <- hGetLine h hClose h return (take 4 loadanswer == "busy") submitToOtherServer = do other <- findOtherReadyServer otherscriptkey <- maybe (getFreshKey >>= \k -> return (scriptkey++k)) return other submitToServerOrStart url serverargs loadbalance pname otherscriptkey serverprog cgiServerEnv -- try to return the scriptkey of another ready server findOtherReadyServer = do regs <- readCgiServerRegistry let otherports = map (\ (_,_,p)->p) (filter (\ (_,prog,_) -> serverprog==prog) regs) findOtherReadyServerInPorts otherports findOtherReadyServerInPorts [] = return Nothing findOtherReadyServerInPorts (p:ps) = do let (ppname,pscriptkey) = splitAt (length pname) p if ppname==pname -- it is a port for the current script version then connectToSocketRepeat scriptServerTimeOut done 0 (p++"@localhost") >>= maybe (findOtherReadyServerInPorts ps) -- no connection (\h -> do isbusy <- getLoadOfServer h if isbusy then findOtherReadyServerInPorts ps else return (Just pscriptkey) ) else findOtherReadyServerInPorts ps -- Execute a command and copy its output to stdout. -- This is necessary since some web servers do not transfer -- the output of cgi programs if the process is not terminated. execAndCopyOutput :: String -> IO () execAndCopyOutput cmd = connectToCommand cmd >>= copyOutputAndClose -- Copy input from the given handle to stdout and close it after eof. copyOutputAndClose :: Handle -> IO () copyOutputAndClose h = do clen <- copyUntilEmptyLine 0 if clen==0 then copyOutputUntilEOF else copyOutputLength clen hClose h where copyUntilEmptyLine clen = do l <- hGetLine h putStrLn l let clen' = if "Content-Length:" `isPrefixOf` l then maybe clen fst (readNat (drop 15 l)) else clen if null l then return clen' else copyUntilEmptyLine clen' copyOutputUntilEOF = do eof <- hIsEOF h if eof then done else hGetLine h >>= putStrLn >> copyOutputUntilEOF copyOutputLength n = do if n>0 then hGetChar h >>= putChar >> copyOutputLength (n-1) else done -- Puts a line to stderr: putErrLn s = hPutStrLn stderr s >> hFlush stderr ------------------------------------------------------------------------------ --- Gets the list of variable/value pairs sent from the browser for the --- current CGI script. --- Used for the implementation of the HTML event handlers. getFormVariables :: IO [(String,String)] getFormVariables = do clen <- getEnviron "CONTENT_LENGTH" cont <- getNChar (maybe 0 fst (readNat clen)) return (includeCoordinates (parseCgiEnv cont)) -- translate a string of cgi environment bindings into list of binding pairs: parseCgiEnv :: String -> [(String,String)] parseCgiEnv s | s == "" = [] | otherwise = map ufield2field (map (\(n,v)->(n,utf2latin (urlencoded2string v))) (map (splitChar '=') (split (=='&') s))) where ufield2field (n,v) = if take 7 n == "UFIELD_" then (tail n, utf2latin (urlencoded2string v)) else (n,v) -- split a string at particular character: splitChar c xs = let (ys,zs) = break (==c) xs in if zs==[] then (ys,zs) else (ys,tail zs) -- split a string at all positions of a particular character: split p xs = let (ys,zs) = break p xs in if zs==[] then [ys] else ys : split p (tail zs) --- Translates urlencoded string into equivalent ASCII string. urlencoded2string :: String -> String urlencoded2string [] = [] urlencoded2string (c:cs) | c == '+' = ' ' : urlencoded2string cs | c == '%' = chr (maybe 0 fst (readHex (take 2 cs))) : urlencoded2string (drop 2 cs) | otherwise = c : urlencoded2string cs --- Transforms a string with UTF-8 umlauts into a string with latin1 umlauts. utf2latin :: String -> String utf2latin [] = [] utf2latin [c] = [c] utf2latin (c1:c2:cs) | ord c1 == 195 = chr (ord c2 + 64) : utf2latin cs | otherwise = c1 : utf2latin (c2:cs) includeCoordinates :: [(String,String)] -> [(String,String)] includeCoordinates [] = [] includeCoordinates ((tag,val):cenv) = case break (=='.') tag of (_,[]) -> (tag,val):includeCoordinates cenv (event,['.','x']) -> ("x",val):(event,val):includeCoordinates cenv (_,['.','y']) -> ("y",val):includeCoordinates cenv _ -> error "includeCoordinates: unexpected . in url parameter" -- get n chars from stdin: getNChar n = if n<=0 then return "" else do c <- getChar cs <- getNChar (n-1) return (c:cs) ------------------------------------------------------------------------------ --- The name of the file to register all cgi servers. cgiServerRegistry = "/tmp/CURRY_CGI_REGISTRY" -- Register a new cgi server process (for global management of all such -- processes on a host): registerCgiServer :: String -> String -> IO () registerCgiServer eurl epname = -- we want to be sure that everything is evaluated before locking: (register $## eurl) $## epname where register url pname = exclusiveIO (cgiServerRegistry++".lock") $ do exreg <- doesFileExist cgiServerRegistry if exreg then done else do writeFile cgiServerRegistry "" system ("chmod 666 "++cgiServerRegistry) >> done pid <- getPID wd <- getCurrentDirectory appendFile cgiServerRegistry (show (pid,wd++"/"++url++".server",pname)++"\n") -- Unregister the previously registered cgi server process: -- processes on a host): unregisterCgiServer :: String -> IO () unregisterCgiServer epname = -- we want to be sure that everything is evaluated before locking: unregister $## epname where unregister pname = exclusiveIO (cgiServerRegistry++".lock") $ do exreg <- doesFileExist cgiServerRegistry if not exreg then done else do mypid <- getPID regs <- readCgiServerRegistry let uregs = filter (\ (pid,_,port) -> mypid/=pid || pname/=port) regs writeFile cgiServerRegistry (concatMap (\reg->show reg++"\n") uregs) -- Return the current server registry: readCgiServerRegistry :: IO [(Int,String,String)] readCgiServerRegistry = do regs <- readQTermListFile cgiServerRegistry seq (length regs) done -- just to be sure that everything is immediately read return regs --------------------------------------------------------------------------- curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/HtmlParser.curry000066400000000000000000000131051305333611600243770ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This module contains a very simple parser for HTML documents. --- --- @author Michael Hanus --- @version March 2015 --- @category web ------------------------------------------------------------------------------ module HtmlParser(readHtmlFile,parseHtmlString) where import HTML import Char --- Reads a file with HTML text and returns the corresponding HTML expressions. --- @param file - the name of a file containing HTML text --- @return a list of HTML expressions (if the file contains exactly one --- HTML document, this list should contain exactly one element) readHtmlFile :: String -> IO [HtmlExp] readHtmlFile file = readFile file >>= return . parseHtmlString ------------------------------------------------------------------------------ --- Transforms an HTML string into a list of HTML expressions. --- If the HTML string is a well structured document, the list --- of HTML expressions should contain exactly one element. parseHtmlString :: String -> [HtmlExp] parseHtmlString s = reverse (parseHtmlTokens [] (scanHtmlString s)) --- The data type for representing HTML tokens. data HtmlToken = HText String | HElem String [(String,String)] -- parse a list of HTML tokens into list of HTML expressions: -- (first argument "helems" is a stack of already read tokens) parseHtmlTokens :: [HtmlExp] -> [HtmlToken] -> [HtmlExp] parseHtmlTokens helems [] = helems parseHtmlTokens helems (HText s : hs) = parseHtmlTokens (HtmlText s : helems) hs parseHtmlTokens helems (HElem (t:ts) args : hs) = if t == '/' then let (structargs,elems,rest) = splitHtmlElems ts helems in parseHtmlTokens ([HtmlStruct ts structargs elems] ++ rest) hs else parseHtmlTokens (HtmlStruct (t:ts) args [] : helems) hs -- split the HTML token stack up to a particular token: splitHtmlElems :: String -> [HtmlExp] -> ([(String,String)],[HtmlExp],[HtmlExp]) splitHtmlElems _ [] = ([],[],[]) splitHtmlElems tag (HtmlText s : hs) = let (largs,elems,rest) = splitHtmlElems tag hs in (largs, elems ++ [HtmlText s], rest) splitHtmlElems tag (HtmlStruct s args cont@(_:_) : hs) = let (largs,elems,rest) = splitHtmlElems tag hs in (largs, elems ++ [HtmlStruct s args cont], rest) splitHtmlElems tag (HtmlStruct s args []: hs) = if tag==s then (args,[],hs) else let (largs,elems,rest) = splitHtmlElems tag hs in (largs, elems ++ [HtmlStruct s args []], rest) -- scan an HTML string into list of HTML tokens: scanHtmlString :: String -> [HtmlToken] scanHtmlString s = scanHtml s where scanHtml [] = [] scanHtml (c:cs) = if c=='<' then if take 3 cs == "!--" then scanHtmlComment cs else if take 4 (map toLower cs) == "pre>" then scanHtmlPre "" (skipFirstNewLine (drop 4 cs)) else scanHtmlElem [] cs else let (initxt,remtag) = break (=='<') (c:cs) in HText initxt : scanHtml remtag -- scan an HTML element scanHtmlElem :: String -> String -> [HtmlToken] scanHtmlElem ct [] = [HText ("<"++ct)] -- incomplete element scanHtmlElem ct (c:cs) | c=='>' = (if null ct then HText "<>" -- invalid HTML, but we accept it... else HElem ct []) : scanHtmlString cs | isSpace c = if null ct then HText "< " : scanHtmlString cs -- invalid HTML, but we accept it... else let (args,rest) = splitAtElement (=='>') (dropWhile isSpace cs) revargs = reverse args in if null args || head revargs /= '/' then HElem ct (string2args args) : scanHtmlString rest else HElem ct (string2args (reverse (tail revargs))) : HElem ('/':ct) [] : scanHtmlString rest | c=='/' && head cs == '>' = HElem ct [] : HElem ('/':ct) [] : scanHtmlString (tail cs) | otherwise = scanHtmlElem (ct++[toLower c]) cs -- scan an HTML comment scanHtmlComment :: String -> [HtmlToken] scanHtmlComment [] = [] scanHtmlComment (c:cs) = if c=='-' && take 2 cs == "->" then scanHtmlString (drop 2 cs) else scanHtmlComment cs -- scan an HTML preformatted element scanHtmlPre :: String -> String -> [HtmlToken] scanHtmlPre _ [] = [] -- errorneous incomplete element scanHtmlPre pre (c:cs) = if c=='<' && take 5 (map toLower cs) == "/pre>" then HElem "pre" [] : HText (reverse pre) : HElem "/pre" [] : scanHtmlString (drop 5 cs) else scanHtmlPre (c:pre) cs -- split a string into blank separated list of strings: string2args :: String -> [(String,String)] string2args [] = [] string2args (c:cs) = let (arg1,rest) = splitAtElement isSpace (c:cs) in deleteApo (splitAtElement (=='=') arg1) : string2args (dropWhile isSpace rest) deleteApo :: (String,String) -> (String,String) deleteApo (tag,[]) = (map toLower tag,[]) deleteApo (tag,c:cs) | c=='"' = (map toLower tag, deleteLastApo cs) | c=='\'' = (map toLower tag, deleteLastApo cs) | otherwise = (map toLower tag, c:cs) deleteLastApo :: String -> String deleteLastApo [] = [] deleteLastApo [c] = if c=='"' || c=='\'' then [] else [c] deleteLastApo (c1:c2:cs) = c1 : deleteLastApo (c2:cs) -- split a list at the first element satisfying a predicate: splitAtElement :: (a -> Bool) -> [a] -> ([a],[a]) splitAtElement _ [] = ([],[]) splitAtElement p (c:cs) = if p c then ([],cs) else let (first,rest) = splitAtElement p cs in (c:first,rest) skipFirstNewLine :: String -> String skipFirstNewLine [] = [] skipFirstNewLine (c:cs) = if c=='\n' then cs else if isSpace c then skipFirstNewLine cs else c:cs -- end of HTML parser curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/IO.curry000066400000000000000000000201751305333611600226320ustar00rootroot00000000000000----------------------------------------------------------------------------- --- Library for IO operations like reading and writing files --- that are not already contained in the prelude. --- --- @author Michael Hanus, Bernd Brassel --- @version March 2015 --- @category general ----------------------------------------------------------------------------- module IO(Handle,IOMode(..),SeekMode(..),stdin,stdout,stderr, openFile,hClose,hFlush,hIsEOF,isEOF, hSeek,hWaitForInput,hWaitForInputs, hWaitForInputOrMsg,hWaitForInputsOrMsg,hReady, hGetChar,hGetLine,hGetContents,getContents, hPutChar,hPutStr,hPutStrLn,hPrint, hIsReadable,hIsWritable,hIsTerminalDevice) where --- The abstract type of a handle for a stream. data Handle -- internally defined --- The modes for opening a file. data IOMode = ReadMode | WriteMode | AppendMode --- The modes for positioning with hSeek in a file. data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd --- Standard input stream. stdin :: Handle stdin external --- Standard output stream. stdout :: Handle stdout external --- Standard error stream. stderr :: Handle stderr external --- Opens a file in specified mode and returns a handle to it. openFile :: String -> IOMode -> IO Handle openFile filename mode = (prim_openFile $## filename) $# mode prim_openFile :: String -> IOMode -> IO Handle prim_openFile external --- Closes a file handle and flushes the buffer in case of output file. hClose :: Handle -> IO () hClose h = prim_hClose $# h prim_hClose :: Handle -> IO () prim_hClose external --- Flushes the buffer associated to handle in case of output file. hFlush :: Handle -> IO () hFlush h = prim_hFlush $# h prim_hFlush :: Handle -> IO () prim_hFlush external --- Is handle at end of file? hIsEOF :: Handle -> IO Bool hIsEOF h = prim_hIsEOF $# h prim_hIsEOF :: Handle -> IO Bool prim_hIsEOF external --- Is standard input at end of file? isEOF :: IO Bool isEOF = hIsEOF stdin --- Set the position of a handle to a seekable stream (e.g., a file). --- If the second argument is AbsoluteSeek, --- SeekFromEnd, or RelativeSeek, --- the position is set relative to the beginning of the file, --- to the end of the file, or to the current position, respectively. hSeek :: Handle -> SeekMode -> Int -> IO () hSeek h sm pos = ((prim_hSeek $# h) $# sm) $# pos prim_hSeek :: Handle -> SeekMode -> Int -> IO () prim_hSeek external --- Waits until input is available on the given handle. --- If no input is available within t milliseconds, it returns False, --- otherwise it returns True. --- @param handle - a handle for an input stream --- @param timeout - milliseconds to wait for input (< 0 : no time out) hWaitForInput :: Handle -> Int -> IO Bool hWaitForInput handle timeout = (prim_hWaitForInput $# handle) $## timeout prim_hWaitForInput :: Handle -> Int -> IO Bool prim_hWaitForInput external --- Waits until input is available on some of the given handles. --- If no input is available within t milliseconds, it returns -1, --- otherwise it returns the index of the corresponding handle with the available --- data. --- @param handles - a list of handles for input streams --- @param timeout - milliseconds to wait for input (< 0 : no time out) --- @return -1 if no input is available within the time out, otherwise i --- if (handles!!i) has data available hWaitForInputs :: [Handle] -> Int -> IO Int hWaitForInputs handles timeout = (prim_hWaitForInputs $## handles) $## timeout prim_hWaitForInputs :: [Handle] -> Int -> IO Int prim_hWaitForInputs external --- Waits until input is available on a given handles or a message --- in the message stream. Usually, the message stream comes from an external port. --- Thus, this operation implements a committed choice over receiving input --- from an IO handle or an external port. --- --- Note that the implementation of this operation works only with --- Sicstus-Prolog 3.8.5 or higher (due to a bug in previous versions --- of Sicstus-Prolog). --- --- @param handle - a handle for an input stream --- @param msgs - a stream of messages received via an external port (see Ports) --- @return (Left handle) if the handle has some data available --- (Right msgs) if the stream msgs is instantiated --- with at least one new message at the head hWaitForInputOrMsg :: Handle -> [msg] -> IO (Either Handle [msg]) hWaitForInputOrMsg handle msgs = do input <- hWaitForInputsOrMsg [handle] msgs return $ either (\_ -> Left handle) Right input --- Waits until input is available on some of the given handles or a message --- in the message stream. Usually, the message stream comes from an external port. --- Thus, this operation implements a committed choice over receiving input --- from IO handles or an external port. --- --- Note that the implementation of this operation works only with --- Sicstus-Prolog 3.8.5 or higher (due to a bug in previous versions --- of Sicstus-Prolog). --- --- @param handles - a list of handles for input streams --- @param msgs - a stream of messages received via an external port (see Ports) --- @return (Left i) if (handles!!i) has some data available --- (Right msgs) if the stream msgs is instantiated --- with at least one new message at the head hWaitForInputsOrMsg :: [Handle] -> [msg] -> IO (Either Int [msg]) hWaitForInputsOrMsg handles msgs = seq (normalForm (map ensureNotFree (ensureSpine handles))) (prim_hWaitForInputsOrMsg handles msgs) prim_hWaitForInputsOrMsg :: [Handle] -> [msg] -> IO (Either Int [msg]) prim_hWaitForInputsOrMsg external --- Checks whether an input is available on a given handle. hReady :: Handle -> IO Bool hReady h = hWaitForInput h 0 --- Reads a character from an input handle and returns it. --- Throws an error if the end of file has been reached. hGetChar :: Handle -> IO Char hGetChar h = prim_hGetChar $# h prim_hGetChar :: Handle -> IO Char prim_hGetChar external --- Reads a line from an input handle and returns it. --- Throws an error if the end of file has been reached while reading --- the *first* character. If the end of file is reached later in the line, --- it ist treated as a line terminator and the (partial) line is returned. hGetLine :: Handle -> IO String hGetLine h = do c <- hGetChar h if c == '\n' then return [] else do eof <- hIsEOF h if eof then return [c] else do cs <- hGetLine h return (c:cs) --- Reads the complete contents from an input handle and closes the input handle --- before returning the contents. hGetContents :: Handle -> IO String hGetContents h = do eof <- hIsEOF h if eof then hClose h >> return "" else do c <- hGetChar h cs <- hGetContents h return (c:cs) --- Reads the complete contents from the standard input stream until EOF. getContents :: IO String getContents = hGetContents stdin --- Puts a character to an output handle. hPutChar :: Handle -> Char -> IO () hPutChar h c = (prim_hPutChar $# h) $## c prim_hPutChar :: Handle -> Char -> IO () prim_hPutChar external --- Puts a string to an output handle. hPutStr :: Handle -> String -> IO () hPutStr _ [] = done hPutStr h (c:cs) = hPutChar h c >> hPutStr h cs --- Puts a string with a newline to an output handle. hPutStrLn :: Handle -> String -> IO () hPutStrLn h s = hPutStr h s >> hPutChar h '\n' --- Converts a term into a string and puts it to an output handle. hPrint :: Handle -> _ -> IO () hPrint h = hPutStrLn h . show --- Is the handle readable? hIsReadable :: Handle -> IO Bool hIsReadable h = prim_hIsReadable $# h prim_hIsReadable :: Handle -> IO Bool prim_hIsReadable external --- Is the handle writable? hIsWritable :: Handle -> IO Bool hIsWritable h = prim_hIsWritable $# h prim_hIsWritable :: Handle -> IO Bool prim_hIsWritable external --- Is the handle connected to a terminal? hIsTerminalDevice :: Handle -> IO Bool hIsTerminalDevice h = prim_hIsTerminalDevice $# h prim_hIsTerminalDevice :: Handle -> IO Bool prim_hIsTerminalDevice external curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/IO.prim_c2p000066400000000000000000000040421305333611600231740ustar00rootroot00000000000000 prim_io prim_stdin prim_io prim_stdout prim_io prim_stderr prim_io prim_openFile prim_io prim_hClose prim_io prim_hFlush prim_io prim_hIsEOF prim_io prim_hSeek prim_io prim_hWaitForInput[raw] prim_io prim_hWaitForInputs[raw] prim_io prim_hWaitForInputsOrMsg[raw] prim_io prim_hGetChar prim_io prim_hPutChar prim_io prim_hIsReadable prim_io prim_hIsWritable prim_io prim_hIsTerminalDevice curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/IOExts.curry000066400000000000000000000125421305333611600234750ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library with some useful extensions to the IO monad. --- --- @author Michael Hanus --- @version January 2017 --- @category general ------------------------------------------------------------------------------ module IOExts ( -- execution of shell commands execCmd, evalCmd, connectToCommand -- file access , readCompleteFile,updateFile, exclusiveIO -- associations , setAssoc,getAssoc -- IORef , IORef, newIORef, readIORef, writeIORef, modifyIORef ) where import System import IO (Handle) --- Executes a command with a new default shell process. --- The standard I/O streams of the new process (stdin,stdout,stderr) --- are returned as handles so that they can be explicitly manipulated. --- They should be closed with IO.hClose since they are not --- closed automatically when the process terminates. --- @param cmd - the shell command to be executed --- @return the handles of the input/output/error streams of the new process execCmd :: String -> IO (Handle, Handle, Handle) execCmd cmd = prim_execCmd $## cmd prim_execCmd :: String -> IO (Handle, Handle, Handle) prim_execCmd external --- Executes a command with the given arguments as a new default shell process --- and provides the input via the process' stdin input stream. --- The exit code of the process and the contents written to the standard --- I/O streams stdout and stderr are returned. --- @param cmd - the shell command to be executed --- @param args - the command's arguments --- @param input - the input to be written to the command's stdin --- @return the exit code and the contents written to stdout and stderr evalCmd :: String -> [String] -> String -> IO (Int, String, String) evalCmd cmd args input = ((prim_evalCmd $## cmd) $## args) $## input prim_evalCmd :: String -> [String] -> String -> IO (Int, String, String) prim_evalCmd external --- Executes a command with a new default shell process. --- The input and output streams of the new process is returned --- as one handle which is both readable and writable. --- Thus, writing to the handle produces input to the process and --- output from the process can be retrieved by reading from this handle. --- The handle should be closed with IO.hClose since they are not --- closed automatically when the process terminates. --- @param cmd - the shell command to be executed --- @return the handle connected to the input/output streams --- of the new process connectToCommand :: String -> IO Handle connectToCommand cmd = prim_connectToCmd $## cmd prim_connectToCmd :: String -> IO Handle prim_connectToCmd external --- An action that reads the complete contents of a file and returns it. --- This action can be used instead of the (lazy) readFile --- action if the contents of the file might be changed. --- @param file - the name of the file --- @return the complete contents of the file readCompleteFile :: String -> IO String readCompleteFile file = do s <- readFile file f s (return s) where f [] r = r f (_:cs) r = f cs r --- An action that updates the contents of a file. --- @param f - the function to transform the contents --- @param file - the name of the file updateFile :: (String -> String) -> String -> IO () updateFile f file = do s <- readCompleteFile file writeFile file (f s) --- Forces the exclusive execution of an action via a lock file. --- For instance, (exclusiveIO "myaction.lock" act) ensures that --- the action "act" is not executed by two processes on the same --- system at the same time. --- @param lockfile - the name of a global lock file --- @param action - the action to be exclusively executed --- @return the result of the execution of the action exclusiveIO :: String -> IO a -> IO a exclusiveIO lockfile action = do system ("lockfile-create --lock-name "++lockfile) catch (do actionResult <- action deleteLockFile return actionResult ) (\e -> deleteLockFile >> ioError e) where deleteLockFile = system $ "lockfile-remove --lock-name " ++ lockfile --- Defines a global association between two strings. --- Both arguments must be evaluable to ground terms before applying --- this operation. setAssoc :: String -> String -> IO () setAssoc key val = (prim_setAssoc $## key) $## val prim_setAssoc :: String -> String -> IO () prim_setAssoc external --- Gets the value associated to a string. --- Nothing is returned if there does not exist an associated value. getAssoc :: String -> IO (Maybe String) getAssoc key = prim_getAssoc $## key prim_getAssoc :: String -> IO (Maybe String) prim_getAssoc external --- Mutable variables containing values of some type. --- The values are not evaluated when they are assigned to an IORef. data IORef _ -- precise structure internally defined --- Creates a new IORef with an initial value. newIORef :: a -> IO (IORef a) newIORef external --- Reads the current value of an IORef. readIORef :: IORef a -> IO a readIORef ref = prim_readIORef $# ref prim_readIORef :: IORef a -> IO a prim_readIORef external --- Updates the value of an IORef. writeIORef :: IORef a -> a -> IO () writeIORef ref val = (prim_writeIORef $# ref) val prim_writeIORef :: IORef a -> a -> IO () prim_writeIORef external --- Modify the value of an IORef. modifyIORef :: IORef a -> (a -> a) -> IO () modifyIORef ref f = readIORef ref >>= writeIORef ref . f curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/IOExts.curry.pakcs000066400000000000000000000146021305333611600245740ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library with some useful extensions to the IO monad. --- --- @author Michael Hanus --- @version January 2017 --- @category general ------------------------------------------------------------------------------ module IOExts ( -- execution of shell commands execCmd, evalCmd, connectToCommand -- file access , readCompleteFile,updateFile, exclusiveIO -- associations , setAssoc,getAssoc -- IORef , IORef, newIORef, readIORef, writeIORef, modifyIORef ) where import Char (isAlphaNum) import Directory (removeFile) import IO import Read (readNat) import System --- Executes a command with a new default shell process. --- The standard I/O streams of the new process (stdin,stdout,stderr) --- are returned as handles so that they can be explicitly manipulated. --- They should be closed with IO.hClose since they are not --- closed automatically when the process terminates. --- @param cmd - the shell command to be executed --- @return the handles of the input/output/error streams of the new process execCmd :: String -> IO (Handle,Handle,Handle) execCmd cmd = prim_execCmd $## cmd prim_execCmd :: String -> IO (Handle,Handle,Handle) prim_execCmd external --- Executes a command with the given arguments as a new default shell process --- and provides the input via the process' stdin input stream. --- The exit code of the process and the contents written to the standard --- I/O streams stdout and stderr are returned. --- @param cmd - the shell command to be executed --- @param args - the command's arguments --- @param input - the input to be written to the command's stdin --- @return the exit code and the contents written to stdout and stderr evalCmd :: String -> [String] -> String -> IO (Int, String, String) evalCmd cmd args input = do pid <- getPID let tmpfile = "/tmp/PAKCS_evalCMD"++show pid (hi,ho,he) <- execCmd (unwords (map wrapArg (cmd:args)) ++ " ; (echo $? > "++tmpfile++")") unless (null input) (hPutStrLn hi input) hClose hi outs <- hGetEOF ho errs <- hGetEOF he ecodes <- readCompleteFile tmpfile removeFile tmpfile return (readNat ecodes, outs, errs) where wrapArg str | null str = "''" -- goodChar is a pessimistic predicate, such that if an argument is -- non-empty and only contains goodChars, then there is no need to -- do any quoting or escaping | all goodChar str = str | otherwise = '\'' : foldr escape "'" str where escape c s | c == '\'' = "'\\''" ++ s | otherwise = c : s goodChar c = isAlphaNum c || c `elem` "-_.,/" --- Reads from an input handle until EOF and returns the input. hGetEOF :: Handle -> IO String hGetEOF h = do eof <- hIsEOF h if eof then hClose h >> return "" else do c <- hGetChar h cs <- hGetEOF h return (c:cs) --- Executes a command with a new default shell process. --- The input and output streams of the new process is returned --- as one handle which is both readable and writable. --- Thus, writing to the handle produces input to the process and --- output from the process can be retrieved by reading from this handle. --- The handle should be closed with IO.hClose since they are not --- closed automatically when the process terminates. --- @param cmd - the shell command to be executed --- @return the handle connected to the input/output streams --- of the new process connectToCommand :: String -> IO Handle connectToCommand cmd = prim_connectToCmd $## cmd prim_connectToCmd :: String -> IO Handle prim_connectToCmd external --- An action that reads the complete contents of a file and returns it. --- This action can be used instead of the (lazy) readFile --- action if the contents of the file might be changed. --- @param file - the name of the file --- @return the complete contents of the file readCompleteFile :: String -> IO String readCompleteFile file = do s <- readFile file f s (return s) where f [] r = r f (_:cs) r = f cs r --- An action that updates the contents of a file. --- @param f - the function to transform the contents --- @param file - the name of the file updateFile :: (String -> String) -> String -> IO () updateFile f file = do s <- readCompleteFile file writeFile file (f s) --- Forces the exclusive execution of an action via a lock file. --- For instance, (exclusiveIO "myaction.lock" act) ensures that --- the action "act" is not executed by two processes on the same --- system at the same time. --- @param lockfile - the name of a global lock file --- @param action - the action to be exclusively executed --- @return the result of the execution of the action exclusiveIO :: String -> IO a -> IO a exclusiveIO lockfile action = do system ("lockfile-create --lock-name "++lockfile) catch (do actionResult <- action deleteLockFile return actionResult ) (\e -> deleteLockFile >> ioError e) where deleteLockFile = system $ "lockfile-remove --lock-name " ++ lockfile --- Defines a global association between two strings. --- Both arguments must be evaluable to ground terms before applying --- this operation. setAssoc :: String -> String -> IO () setAssoc key val = (prim_setAssoc $## key) $## val prim_setAssoc :: String -> String -> IO () prim_setAssoc external --- Gets the value associated to a string. --- Nothing is returned if there does not exist an associated value. getAssoc :: String -> IO (Maybe String) getAssoc key = prim_getAssoc $## key prim_getAssoc :: String -> IO (Maybe String) prim_getAssoc external --- Mutable variables containing values of some type. --- The values are not evaluated when they are assigned to an IORef. data IORef a = IORef a -- precise structure internally defined --- Creates a new IORef with an initial value. newIORef :: a -> IO (IORef a) newIORef external --- Reads the current value of an IORef. readIORef :: IORef a -> IO a readIORef ref = prim_readIORef $# ref prim_readIORef :: IORef a -> IO a prim_readIORef external --- Updates the value of an IORef. writeIORef :: IORef a -> a -> IO () writeIORef ref val = (prim_writeIORef $# ref) val prim_writeIORef :: IORef a -> a -> IO () prim_writeIORef external --- Modify the value of an IORef. modifyIORef :: IORef a -> (a -> a) -> IO () modifyIORef ref f = readIORef ref >>= writeIORef ref . f curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/IOExts.prim_c2p000066400000000000000000000020041305333611600240340ustar00rootroot00000000000000 prim_ioexts prim_execCmd prim_ioexts prim_connectToCmd prim_ioexts prim_setAssoc prim_ioexts prim_getAssoc prim_ioexts prim_newIORef[raw] prim_ioexts prim_readIORef[raw] prim_ioexts prim_writeIORef[raw] curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Integer.curry000066400000000000000000000143401305333611600237150ustar00rootroot00000000000000------------------------------------------------------------------------------ --- A collection of common operations on integer numbers. --- Most operations make no assumption on the precision of integers. --- Operation `bitNot` is necessarily an exception. --- --- @author Sergio Antoy --- @version July 2014 --- @category general ------------------------------------------------------------------------------ module Integer((^), pow, ilog, isqrt, factorial, binomial, abs, max3, min3, maxlist, minlist, bitTrunc, bitAnd, bitOr, bitNot, bitXor, even, odd) where infixr 8 ^ ------------------------------------------------------------------ -- Public Operations ------------------------------------------------------------------ --- The value of `a ^ b` is `a` raised to the power of `b`. --- Fails if `b < 0`. --- Executes in `O(log b)` steps. --- --- @param a - The base. --- @param b - The exponent. --- @return `a` raised to the power of `b`. (^) :: Int -> Int -> Int a ^ b = pow a b --- The value of `pow a b` is `a` --- raised to the power of `b`. --- Fails if `b < 0`. --- Executes in `O(log b)` steps. --- --- @param a - The base. --- @param b - The exponent. --- @return `a` raised to the power of `b`. pow :: Int -> Int -> Int pow a b | b>= 0 = powaux 1 a b where powaux n x y = if y == 0 then n else powaux (n * if (y `mod` 2 == 1) then x else 1) (x * x) (y `div` 2) --- The value of `ilog n` is the floor of the logarithm --- in the base 10 of `n`. --- Fails if `n <= 0`. --- For positive integers, the returned value is --- 1 less the number of digits in the decimal representation of `n`. --- --- @param n - The argument. --- @return the floor of the logarithm in the base 10 of `n`. ilog :: Int -> Int ilog n | n>0 = if n<10 then 0 else 1 + ilog (n `div` 10) --- The value of `isqrt n` is the floor --- of the square root of `n`. --- Fails if `n < 0`. --- Executes in `O(log n)` steps, but there must be a better way. --- --- @param n - The argument. --- @return the floor of the square root of `n`. isqrt :: Int -> Int isqrt n | n >= 0 = if n == 0 then 0 else if n < 4 then 1 else aux 2 n where aux low past = -- invariant low <= result < past if past == low+1 then low else let cand = (past + low) `div` 2 in if cand*cand > n then aux low cand else aux cand past --- The value of `factorial n` is the factorial of `n`. --- Fails if `n < 0`. --- --- @param n - The argument. --- @return the factorial of `n`. factorial :: Int -> Int factorial n | n >= 0 = if n == 0 then 1 else n * factorial (n-1) --- The value of `binomial n m` is --- n*(n-1)*...*(n-m+1)/m*(m-1)*...1 --- Fails if `m <= 0` or `n < m`. --- --- @param n - Argument. --- @param m - Argument. --- @return the binomial coefficient of `n` over `m`. binomial :: Int -> Int -> Int binomial n m | m > 0 && n >= m = aux m n `div` factorial m where aux x y = if x == 0 then 1 else y * aux (x-1) (y-1) --- The value of `abs n` is the absolute value of `n`. --- --- @param n - The argument. --- @return the absolute value of `n`. abs :: Int -> Int abs n = if n<0 then -n else n --- Returns the maximum of the three arguments. --- --- @param n - Argument. --- @param m - Argument. --- @param p - Argument. --- @return the maximum among `n`, `m` and `p`. max3 :: a -> a -> a -> a max3 n m p = max n (max m p) --- Returns the minimum of the three arguments. --- --- @param n - Argument. --- @param m - Argument. --- @param p - Argument. --- @return the minimum among `n`, `m` and `p`. min3 :: a -> a -> a -> a min3 n m p = min n (min m p) --- Returns the maximum of a list of integer values. --- Fails if the list is empty. --- --- @param l - The list of values. --- @return the maximum element of `l`. maxlist :: [a] -> a maxlist [n] = n maxlist (n:m:ns) = max n (maxlist (m:ns)) --- Returns the minimum of a list of integer values. --- Fails if the list is empty. --- --- @param l - The list of values. --- @return the minimum element of `l`. minlist :: [a] -> a minlist [n] = n minlist (n:m:ns) = min n (minlist (m:ns)) --- The value of `bitTrunc n m` is the value of the `n` --- least significant bits of `m`. --- --- @param n - Argument. --- @param m - Argument. --- @return `m` truncated to the `n` least significant bits. bitTrunc :: Int -> Int -> Int bitTrunc n m = bitAnd (pow 2 n - 1) m --- Returns the bitwise AND of the two arguments. --- --- @param n - Argument. --- @param m - Argument. --- @return the bitwise and of `n` and `m`. bitAnd :: Int -> Int -> Int bitAnd n m = if m == 0 then 0 else let p = 2 * bitAnd (n `div` 2) (m `div` 2) q = if m `mod` 2 == 0 then 0 else n `mod` 2 in p + q --- Returns the bitwise inclusive OR of the two arguments. --- --- @param n - Argument. --- @param m - Argument. --- @return the bitwise inclusive or of `n` and `m`. bitOr :: Int -> Int -> Int bitOr n m = if m == 0 then n else let p = 2 * bitOr (n `div` 2) (m `div` 2) q = if m `mod` 2 == 1 then 1 else n `mod` 2 in p + q --- Returns the bitwise NOT of the argument. --- Since integers have unlimited precision, --- only the 32 least significant bits are computed. --- --- @param n - Argument. --- @return the bitwise negation of `n` truncated to 32 bits. bitNot :: Int -> Int bitNot n = aux 32 n where aux c m = if c==0 then 0 else let p = 2 * aux (c-1) (m `div` 2) q = 1 - m `mod` 2 in p + q --- Returns the bitwise exclusive OR of the two arguments. --- --- @param n - Argument. --- @param m - Argument. --- @return the bitwise exclusive of `n` and `m`. bitXor :: Int -> Int -> Int bitXor n m = if m == 0 then n else let p = 2 * bitXor (n `div` 2) (m `div` 2) q = if m `mod` 2 == n `mod` 2 then 0 else 1 in p + q --- Returns whether an integer is even --- --- @param n - Argument. --- @return whether `n` is even. even :: Int -> Bool even n = n `mod` 2 == 0 --- Returns whether an integer is odd --- --- @param n - Argument. --- @return whether `n` is odd. odd :: Int -> Bool odd n = n `mod` 2 /= 0 curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/JavaScript.curry000066400000000000000000000115261305333611600243710ustar00rootroot00000000000000------------------------------------------------------------------------------ --- A library to represent JavaScript programs. --- --- @author Michael Hanus --- @version January 22, 2007 --- @category general ------------------------------------------------------------------------------ module JavaScript(JSExp(..),JSStat(..),JSBranch(..),JSFDecl(..), showJSExp,showJSStat,showJSFDecl, jsConsTerm) where import List(intersperse) ------------------------------------------------------------------------------ --- Type of JavaScript expressions. --- @cons JSString - string constant --- @cons JSInt - integer constant --- @cons JSBool - Boolean constant --- @cons JSIVar - indexed variable --- @cons JSIArrayIdx - array access to index array variable --- @cons JSOp - infix operator expression --- @cons JSFCall - function call --- @cons JSApply - function call where the function is an expression --- @cons JSLambda - (anonymous) function with indexed variables as arguments data JSExp = JSString String | JSInt Int | JSBool Bool | JSIVar Int | JSIArrayIdx Int Int | JSOp String JSExp JSExp | JSFCall String [JSExp] | JSApply JSExp JSExp | JSLambda [Int] [JSStat] --- Type of JavaScript statements. --- @cons JSAssign - assignment --- @cons JSIf - conditional --- @cons JSSwitch - switch statement --- @cons JSPCall - procedure call --- @cons JSReturn - return statement --- @cons JSVarDecl - local variable declaration data JSStat = JSAssign JSExp JSExp | JSIf JSExp [JSStat] [JSStat] | JSSwitch JSExp [JSBranch] | JSPCall String [JSExp] | JSReturn JSExp | JSVarDecl Int -- Type of branches in a switch statement. --- @cons JSCase - case branch --- @cons JSDefault - default branch data JSBranch = JSCase String [JSStat] | JSDefault [JSStat] -- Type of JavaScript function declarations. data JSFDecl = JSFDecl String [Int] [JSStat] ------------------------------------------------------------------------------ --- Shows a JavaScript expression as a string in JavaScript syntax. showJSExp :: JSExp -> String showJSExp (JSString s) = "\""++s++"\"" showJSExp (JSInt i) = show i showJSExp (JSBool b) = if b then "true" else "false" showJSExp (JSIVar i) = "x"++show i showJSExp (JSIArrayIdx ai i) = "x"++show ai++"["++show i++"]" showJSExp (JSOp op e1 e2) = "(" ++ showJSExp e1 ++ " " ++ op ++ " " ++ showJSExp e2 ++ ")" showJSExp (JSFCall f args) = f ++ "(" ++ concat (intersperse "," (map showJSExp args)) ++ ")" showJSExp (JSApply f e) = showJSExp f ++ "(" ++ showJSExp e ++ ")" showJSExp (JSLambda params body) = "function(" ++ concat (intersperse "," (map (showJSExp . JSIVar) params)) ++ ") {" ++ concatMap (showJSStat 1) body ++ "} " --- Shows a JavaScript statement as a string in JavaScript syntax --- with indenting. --- @param i - number of spaces to indent this statement --- @param jstat - the JavaScript statement to print showJSStat :: Int -> JSStat -> String showJSStat i (JSAssign e1 e2) = blanks i ++ showJSExp e1 ++ " = " ++ showJSExp e2 ++";" showJSStat i (JSIf e s1 s2) = blanks i ++ "if ("++showJSExp e++") {\n"++ concatMap ((++"\n") . (showJSStat (i+2))) s1 ++ if null s2 then blanks i ++ "}" else blanks i ++ "} else {\n" ++ concatMap ((++"\n") . (showJSStat (i+2))) s2 ++ blanks i ++ "}" showJSStat i (JSSwitch e bs) = blanks i ++ "switch ("++showJSExp e++") {\n"++ concatMap showJSBranch bs ++ blanks i ++ "}" where showJSBranch (JSCase cs bstats) = blanks (i+2) ++ "case \"" ++ cs ++ "\" :\n" ++ concatMap ((++"\n") . (showJSStat (i+4))) bstats ++ blanks (i+4) ++ "break;\n" showJSBranch (JSDefault bstats) = blanks (i+2) ++ "default :\n" ++ concatMap ((++"\n") . (showJSStat (i+4))) bstats showJSStat i (JSPCall p args) = blanks i ++ p ++ "(" ++ concat (intersperse "," (map showJSExp args)) ++ ")" showJSStat i (JSReturn e) = blanks i ++ "return " ++ showJSExp e ++";" showJSStat i (JSVarDecl vi) = blanks i ++ "var x" ++ show vi ++";" blanks n = replicate n ' ' --- Shows a JavaScript function declaration as a string in JavaScript syntax. showJSFDecl (JSFDecl f args body) = "function " ++ f ++ "(" ++ concat (intersperse "," (map showJSExp (map JSIVar args))) ++ ") {\n" ++ concatMap ((++"\n") . (showJSStat 2)) body ++"}\n\n" ------------------------------------------------------------------------------ --- Representation of constructor terms in JavaScript. --- @param cons - the name of the data constructor --- @param args - the arguments of the constructor term jsConsTerm :: String -> [JSExp] -> JSExp jsConsTerm cons args = JSFCall "new Array" (JSString cons : args) ------------------------------------------------------------------------------ curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/KeyDB.curry.pakcs000066400000000000000000000105621305333611600243600ustar00rootroot00000000000000--- This module provides a general interface for databases --- (persistent predicates) where each entry consists of a key and an info --- part. The key is an integer and the info is arbitrary. --- All functions are parameterized with a dynamic predicate that --- takes an integer key as a first parameter. --- --- Remark: --- This library has been revised to the library KeyDatabase. --- Thus, it might not be further supported in the future. --- --- @author Bernd Brassel, Michael Hanus --- @version January 2006 --- @category database module KeyDB(existsDBKey,allDBKeys,getDBInfo,getDBInfos, deleteDBEntry,updateDBEntry,newDBEntry,cleanDB, index,sortByIndex,groupByIndex) where import Dynamic import Integer(maxlist) import Sort import List --- Exists an entry with a given key in the database? --- @param db - the database (a dynamic predicate) --- @param key - a key (an integer) existsDBKey :: (Int -> _ -> Dynamic) -> Int -> IO Bool existsDBKey db key = seq db $ seq key $ do entries <- getDynamicSolution (\info -> db key info) return (entries /= Nothing) --- Returns all keys of entries in the database. allDBKeys :: (Int -> _ -> Dynamic) -> IO [Int] allDBKeys db = seq db $ do getDynamicSolutions (\key -> db key unknown) --- Gets the information about an entry in the database. --- @param db - the database (a dynamic predicate) --- @param key - the key of the entry (an integer) getDBInfo :: (Int -> a -> Dynamic) -> Int -> IO a getDBInfo db key = seq db $ seq key $ do entries <- getDynamicSolutions (\info -> db key info) if null entries then error ("getDBInfo: no entry for key '"++show key++"'") else return (head entries) --- compute the position of an entry in a list --- fail, if given entry is not an element. --- @param x - the entry searched for --- @param xs - the list to search in index :: a -> [a] -> Int index x xs = idx 0 xs where idx n (y:ys) = if x==y then n else idx (n+1) ys --- Sorts a given list by associated index . sortByIndex :: [(Int,b)] -> [b] sortByIndex = map snd . mergeSortBy (\x y -> fst x < fst y) --- Sorts a given list by associated index and group for identical index. --- Empty lists are added for missing indexes groupByIndex :: [(Int,b)] -> [[b]] groupByIndex = addEmptyIdxs 0 . groupBy (\x y -> fst x == fst y) . mergeSortBy (\x y -> fst x < fst y) where addEmptyIdxs _ [] = [] addEmptyIdxs n (((m,x):xs):ys) = if n==m then (x:map snd xs) : addEmptyIdxs (n+1) ys else []:addEmptyIdxs (n+1) (((m,x):xs):ys) --- Gets the information about a list of entries in the database. --- @param db - the database (a dynamic predicate) --- @param keys - the list of keys of the entry (integers) getDBInfos :: (Int -> a -> Dynamic) -> [Int] -> IO [a] getDBInfos db keys = seq db $ seq (normalForm keys) $ do entries <- getDynamicSolutions (\ (i,info) -> let key free in db key info |&> (i=:=index key keys)) return (sortByIndex entries) --- Deletes an entry with a given key in the database. --- @param db - the database (a dynamic predicate) --- @param key - the key of the entry (an integer) deleteDBEntry :: (Int -> _ -> Dynamic) -> Int -> IO () deleteDBEntry db key = seq db $ seq key $ do entries <- getDynamicSolutions (\infos -> db key infos) mapIO_ (\infos -> retract (db key infos)) entries --- Overwrites an existing entry in the database. --- @param db - the database (a dynamic predicate) --- @param key - the key of the entry (an integer) --- @param info - the information to be stored in the updated entry updateDBEntry :: (Int -> a -> Dynamic) -> Int -> a -> IO () updateDBEntry db key info = do deleteDBEntry db key assert (db key info) --- Return a new database key. newDBKey :: (Int -> _ -> Dynamic) -> IO Int newDBKey db = do ids <- getDynamicSolutions (\i -> db i unknown) return (if null ids then 1 else maxlist ids + 1) --- Stores a new entry in the database and return the key of the new entry. --- @param db - the database (a dynamic predicate) --- @param info - the information to be stored in the new entry newDBEntry :: (Int -> a -> Dynamic) -> a -> IO Int newDBEntry db info = do i <- newDBKey db assert (db i info) return i --- Deletes all entries in the database. cleanDB :: (Int -> _ -> Dynamic) -> IO () cleanDB db = do ids <- getDynamicSolutions (\i -> db i unknown) mapIO_ (\i -> deleteDBEntry db i) ids curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/KeyDatabase.curry.pakcs000066400000000000000000000137701305333611600256030ustar00rootroot00000000000000--------------------------------------------------------------------------- --- This module provides a general interface for databases --- (persistent predicates) where each entry consists of a key and an info --- part. The key is an integer and the info is arbitrary. --- All functions are parameterized with a dynamic predicate that --- takes an integer key as a first parameter. --- --- @author Bernd Brassel, Michael Hanus --- @version August 2011 --- @category database --------------------------------------------------------------------------- module KeyDatabase(existsDBKey,allDBKeys,allDBInfos,allDBKeyInfos, getDBInfo,getDBInfos, deleteDBEntry,deleteDBEntries, updateDBEntry,newDBEntry,newDBKeyEntry, cleanDB, index,sortByIndex,groupByIndex, module Database) where import Database import Integer(maxlist) import Sort import List import Maybe(sequenceMaybe) --- The type of a database key is an integer. type Key = Int --- Each entry of a key database contains a key and an information component. type KeyPred a = Key -> a -> Dynamic --- Exists an entry with a given key in the database? --- @param db - the database (a dynamic predicate) --- @param key - a key (an integer) existsDBKey :: KeyPred _ -> Key -> Query Bool existsDBKey db key = seq db $ seq key $ transformQ (/=Nothing) (queryOne (db key)) --- Query that returns all keys of entries in the database. allDBKeys :: KeyPred _ -> Query [Key] allDBKeys db = seq db $ queryAll (\key -> db key unknown) --- Query that returns all infos of entries in the database. allDBInfos :: KeyPred a -> Query [a] allDBInfos db = seq db $ queryAll (db unknown) --- Query that returns all key/info pairs of the database. allDBKeyInfos :: KeyPred a -> Query [(Key,a)] allDBKeyInfos db = seq db $ queryAll (\ (key,info) -> db key info) --- Gets the information about an entry in the database. --- @param db - the database (a dynamic predicate) --- @param key - the key of the entry (an integer) getDBInfo :: KeyPred a -> Key -> Query (Maybe a) getDBInfo db key = seq db $ seq key $ queryOne (\info -> db key info) --- compute the position of an entry in a list --- fail, if given entry is not an element. --- @param x - the entry searched for --- @param xs - the list to search in index :: a -> [a] -> Int index x xs = idx 0 xs where idx n (y:ys) = if x==y then n else idx (n+1) ys --- Sorts a given list by associated index . sortByIndex :: [(Int,b)] -> [b] sortByIndex = map snd . mergeSortBy (\x y -> fst x < fst y) --- Sorts a given list by associated index and group for identical index. --- Empty lists are added for missing indexes groupByIndex :: [(Int,b)] -> [[b]] groupByIndex = addEmptyIdxs 0 . groupBy (\x y -> fst x == fst y) . mergeSortBy (\x y -> fst x < fst y) where addEmptyIdxs _ [] = [] addEmptyIdxs n (((m,x):xs):ys) = if n==m then (x:map snd xs) : addEmptyIdxs (n+1) ys else []:addEmptyIdxs (n+1) (((m,x):xs):ys) --- Gets the information about a list of entries in the database. --- @param db - the database (a dynamic predicate) --- @param keys - the list of keys of the entry (integers) getDBInfos :: KeyPred a -> [Key] -> Query (Maybe [a]) getDBInfos db keys = seq db $ seq (normalForm keys) $ transformQ sortByKeys (queryAll (\ (key,info) -> db key info |> key `elem` keys)) where sortByKeys keyinfos = sequenceMaybe (map (\k -> lookup k keyinfos) keys) --- Deletes an entry with a given key in the database. --- No error is raised if the given key does not exist. --- @param db - the database (a dynamic predicate) --- @param key - the key of the entry (an integer) deleteDBEntry :: KeyPred _ -> Key -> Transaction () deleteDBEntry db key = seq db $ seq key $ getDB (queryAll (\infos -> db key infos)) |>>= \entries -> mapT_ (\infos -> deleteDB (db key infos)) entries --- Deletes all entries with the given keys in the database. --- No error is raised if some of the given keys does not exist. --- @param db - the database (a dynamic predicate) --- @param keys - the list of keys of the entries to be deleted deleteDBEntries :: KeyPred _ -> [Key] -> Transaction () deleteDBEntries db keys = seq db $ seq keys $ mapT_ (deleteDBEntry db) keys --- Overwrites an existing entry in the database. --- @param db - the database (a dynamic predicate) --- @param key - the key of the entry (an integer) --- @param info - the information to be stored in the updated entry updateDBEntry :: KeyPred a -> Key -> a -> Transaction () updateDBEntry db key info = getDB (existsDBKey db key) |>>= \b -> if b then deleteDBEntry db key |>> addDB (db key info) else errorT (TError KeyNotExistsError ("updateDBEntry: key " ++ show key++" does not exist")) --- A query that returns a new database key. newDBKey :: KeyPred _ -> Query Key newDBKey db = transformQ (\ids -> if null ids then 1 else maxlist ids + 1) (queryAll (\i -> db i unknown)) --- Stores a new entry in the database and return the key of the new entry. --- @param db - the database (a dynamic predicate) --- @param info - the information to be stored in the new entry newDBEntry :: KeyPred a -> a -> Transaction Key newDBEntry db info = getDB (newDBKey db) |>>= \i -> addDB (db i info) |>> returnT i --- Stores a new entry in the database under a given key. --- The transaction fails if the key already exists. --- @param db - the database (a dynamic predicate) --- @param key - the key of the new entry (an integer) --- @param info - the information to be stored in the new entry newDBKeyEntry :: KeyPred a -> Key -> a -> Transaction () newDBKeyEntry db key info = getDB (existsDBKey db key) |>>= \b -> if b then errorT (TError DuplicateKeyError ("database already contains entry with key: "++show key)) else addDB (db key info) |>> doneT --- Deletes all entries in the database. cleanDB :: KeyPred _ -> Transaction () cleanDB db = getDB (queryAll (\i -> db i unknown)) |>>= deleteDBEntries db curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/KeyDatabaseSQLite.curry000066400000000000000000000615121305333611600255620ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This module provides a general interface for databases (persistent --- predicates) where each entry consists of a key and an info --- part. The key is an integer and the info is arbitrary. All --- functions are parameterized with a dynamic predicate that takes an --- integer key as a first parameter. --- --- This module reimplements the interface of the module --- `KeyDatabase` based on the --- [SQLite](http://sqlite.org/) database engine. --- In order to use it you need to have `sqlite3` in your --- `PATH` environment variable or adjust the value of the --- constant `path'to'sqlite3`. --- --- Programs that use the `KeyDatabase` module can be adjusted --- to use this module instead by replacing the imports of --- `Dynamic`, `Database`, and --- `KeyDatabase` with this module and changing the declarations --- of database predicates to use the function `persistentSQLite` --- instead of `dynamic` or `persistent`. --- This module redefines the types `Dynamic`, --- `Query`, and `Transaction` and although both --- implementations can be used in the same program (by importing modules --- qualified) they cannot be mixed. --- --- Compared with the interface of `KeyDatabase`, this module --- lacks definitions for `index`, `sortByIndex`, --- `groupByIndex`, and `runTNA` and adds the --- functions `deleteDBEntries` and `closeDBHandles`. --- --- @author Sebastian Fischer with changes by Michael Hanus --- @version August 2011 --- @category database ------------------------------------------------------------------------------ module KeyDatabaseSQLite ( Key, KeyPred, Query, runQ, transformQ, getDB, Transaction, TError(..), TErrorKind(..), showTError, runT, runJustT, returnT, doneT, errorT, failT, (|>>=), (|>>), sequenceT, sequenceT_, mapT, mapT_, Dynamic, persistentSQLite, closeDBHandles, existsDBKey, allDBKeys, allDBInfos, allDBKeyInfos, ColVal, (@=), someDBKeys, someDBInfos, someDBKeyInfos, someDBKeyProjections, getDBInfo, getDBInfos, deleteDBEntry, deleteDBEntries, updateDBEntry, newDBEntry, newDBKeyEntry, cleanDB ) where import Global ( Global, GlobalSpec(..), global, readGlobal, writeGlobal ) import IO ( Handle, hPutStrLn, hGetLine, hFlush, hClose, stderr ) import IOExts ( connectToCommand ) import List ( intersperse, insertBy ) import Maybe ( mapMMaybe ) import ReadNumeric ( readInt ) import ReadShowTerm ( readQTerm, showQTerm, readsQTerm ) import System ( system ) infixl 1 |>>, |>>= -- adjust this if 'sqlite3' is not in the PATH path'to'sqlite3 :: String path'to'sqlite3 = "sqlite3" -- Query and Transaction types --- Queries can read but not write to the database. data Query a = Query (IO a) --- Runs a database query in the IO monad. runQ :: Query a -> IO a runQ (Query a) = a --- Applies a function to the result of a database query. transformQ :: (a -> b) -> Query a -> Query b transformQ f query = Query (runQ query >>= return . f) --- Transactions can modify the database and are executed --- atomically. data Transaction a = Trans (IO (TransResult a)) data TransResult a = OK a | Error TError unTrans :: Transaction a -> IO (TransResult a) unTrans (Trans action) = action --- Runs a transaction atomically in the IO monad. --- --- Transactions are immediate, which means that locks are --- acquired on all databases as soon as the transaction is --- started. After one transaction is started, no other database --- connection will be able to write to the database or start a --- transaction. Other connections can read the database --- during a transaction of another process. --- --- The choice to use immediate rather than deferred transactions is --- conservative. It might also be possible to allow multiple --- simultaneous transactions that lock tables on the first database --- access (which is the default in SQLite). However this leads to --- unpredictable order in which locks are taken when multiple --- databases are involved. The current implementation fixes the --- locking order by sorting databases by their name and locking them --- in order immediately when a transaction begins. --- --- More information on --- transactions --- in SQLite is available online. --- runT :: Transaction a -> IO (Either a TError) runT trans = do beginTransaction result <- catchTrans $ unTrans trans case result of Error err -> do rollbackTransaction return (Right err) OK res -> do commitTransaction return (Left res) catchTrans :: IO (TransResult a) -> IO (TransResult a) catchTrans action = action `catch` \terr -> do err <- readGlobal lastQueryError writeGlobal lastQueryError Nothing return . Error $ maybe (TError ExecutionError (showError terr)) id err --- Executes a possibly composed transaction on the current state --- of dynamic predicates as a single transaction. --- Similar to runT but a run-time error is raised --- if the execution of the transaction fails. runJustT :: Transaction a -> IO a runJustT t = runT t >>= return . either id (\e -> error ("Transaction failed: " ++ showTError e)) --- Lifts a database query to the transaction type such that it can be --- composed with other transactions. Run-time errors that occur --- during the execution of the given query are transformed into --- transaction errors. getDB :: Query a -> Transaction a getDB query = Trans . catchTrans $ runQ query >>= return . OK -- not exported transIO :: IO a -> Transaction a transIO action = Trans (action >>= return . OK) --- Returns the given value in a transaction that does not access the --- database. returnT :: a -> Transaction a returnT = transIO . return --- Returns the unit value in a transaction that does not access the --- database. Useful to ignore results when composing transactions. doneT :: Transaction () doneT = transIO done --- Aborts a transaction with an error. errorT :: TError -> Transaction a errorT = Trans . return . Error --- Aborts a transaction with a user-defined error message. failT :: String -> Transaction a failT = errorT . TError UserDefinedError --- Combines two transactions into a single transaction that executes --- both in sequence. The first transaction is executed, its result --- passed to the function which computes the second transaction, --- which is then executed to compute the final result. --- --- If the first transaction is aborted with an error, the second --- transaction is not executed. (|>>=) :: Transaction a -> (a -> Transaction b) -> Transaction b (Trans action) |>>= f = Trans $ do result <- action case result of Error err -> return $ Error err OK res -> unTrans $ f res --- Combines two transactions to execute them in sequence. The result of --- the first transaction is ignored. (|>>) :: Transaction _ -> Transaction a -> Transaction a t1 |>> t2 = t1 |>>= const t2 --- Executes a list of transactions sequentially and computes a list --- of all results. sequenceT :: [Transaction a] -> Transaction [a] sequenceT = foldr seqT (returnT []) where seqT t ts = t |>>= \x -> ts |>>= \xs -> returnT (x:xs) --- Executes a list of transactions sequentially, ignoring their --- results. sequenceT_ :: [Transaction _] -> Transaction () sequenceT_ = foldr (|>>) doneT --- Applies a function that yields transactions to all elements of a --- list, executes the transaction sequentially, and collects their --- results. mapT :: (a -> Transaction b) -> [a] -> Transaction [b] mapT f = sequenceT . map f --- Applies a function that yields transactions to all elements of a --- list, executes the transactions sequentially, and ignores their --- results. mapT_ :: (a -> Transaction _) -> [a] -> Transaction () mapT_ f = sequenceT_ . map f -- Interface based on keys type DBFile = String type TableName = String type ColName = String --- Result type of database predicates. data Dynamic = DBInfo DBFile TableName [ColName] type Key = Int type KeyPred a = Key -> a -> Dynamic -- for interface compatibility dbInfo :: KeyPred a -> (DBFile,(TableName,[ColName])) dbInfo keyPred = (db,(table,cols)) where DBInfo db table cols = keyPred ignored ignored ignored :: a ignored = error "unexpected access to argument of database predicate" dbFile :: KeyPred _ -> DBFile dbFile = fst . dbInfo tableName :: KeyPred _ -> TableName tableName = fst . snd . dbInfo colNames :: KeyPred _ -> [ColName] colNames = snd . snd . dbInfo --- This function is used instead of dynamic or --- persistent to declare predicates whose facts are stored --- in an SQLite database. --- --- If the provided database or the table do not exist they are created --- automatically when the declared predicate is accessed for the first time. --- --- Multiple column names can be provided if the second argument of --- the predicate is a tuple with a matching arity. Other record types --- are not supported. If no column names are provided a table with a --- single column called info is created. Columns of name --- _rowid_ are not supported and lead to a run-time --- error. --- --- @param dbFile - the name of the associated database file --- @param tableName - the name of the associated database table --- @param colNames - the column names of the associated database table persistentSQLite :: DBFile -> TableName -> [ColName] -> KeyPred a persistentSQLite db table cols _ _ | null cols = DBInfo db table ["info"] | "_rowid_" `elem` cols = error "columns must not be called _rowid_" | otherwise = DBInfo db table cols --- Checks whether the predicate has an entry with the given key. existsDBKey :: KeyPred _ -> Key -> Query Bool existsDBKey keyPred key = Query $ do n <- selectInt keyPred "count(*)" $ "where _rowid_ = " ++ show key return $! n > 0 --- Returns a list of all stored keys. Do not use this function unless --- the database is small. allDBKeys :: KeyPred _ -> Query [Key] allDBKeys keyPred = Query $ do rows <- selectRows keyPred "_rowid_" "" mapIO readIntOrExit rows --- Returns a list of all info parts of stored entries. Do not use this --- function unless the database is small. allDBInfos :: KeyPred a -> Query [a] allDBInfos keyPred = Query $ do rows <- selectRows keyPred "*" "" return $!! map readInfo rows readInfo :: String -> a readInfo str = readQTerm $ "(" ++ str ++ ")" --- Returns a list of all stored entries. Do not use this function --- unless the database is small. allDBKeyInfos :: KeyPred a -> Query [(Key,a)] allDBKeyInfos keyPred = Query $ do rows <- selectRows keyPred "_rowid_,*" "" mapIO readKeyInfo rows readKeyInfo :: String -> IO (Key,a) readKeyInfo row = do key <- readIntOrExit keyStr return $!! (key, readInfo infoStr) where (keyStr,_:infoStr) = break (','==) row --- Abstract type for value restrictions data ColVal = ColVal Int String --- Constructs a value restriction for the column given as first argument (@=) :: Int -> a -> ColVal n @= x = ColVal n . quote $ showQTerm x --- Returns a list of those stored keys where the corresponding info --- part matches the gioven value restriction. Safe to use even on --- large databases if the number of results is small. someDBKeys :: KeyPred _ -> [ColVal] -> Query [Key] someDBKeys keyPred cvs = Query $ do rows <- selectSomeRows keyPred cvs "_rowid_" mapIO readIntOrExit rows --- Returns a list of those info parts of stored entries that match --- the given value restrictions for columns. Safe to use even on --- large databases if the number of results is small. someDBInfos :: KeyPred a -> [ColVal] -> Query [a] someDBInfos keyPred cvs = Query $ do rows <- selectSomeRows keyPred cvs "*" return $!! map readInfo rows --- Returns a list of those entries that match the given value --- restrictions for columns. Safe to use even on large databases if --- the number of results is small. someDBKeyInfos :: KeyPred a -> [ColVal] -> Query [(Key,a)] someDBKeyInfos keyPred cvs = Query $ do rows <- selectSomeRows keyPred cvs "_rowid_,*" mapIO readKeyInfo rows --- Returns a list of column projections on --- those entries that match the given value --- restrictions for columns. Safe to use even on large databases if --- the number of results is small. someDBKeyProjections :: KeyPred a -> [Int] -> [ColVal] -> Query [(Key,b)] someDBKeyProjections keyPred cols cvs = Query $ do let colnames = commaSep (map ((colNames keyPred) !!) cols) rows <- selectSomeRows keyPred cvs ("_rowid_,"++colnames) mapIO readKeyInfo rows --- Queries the information stored under the given key. Yields --- Nothing if the given key is not present. getDBInfo :: KeyPred a -> Key -> Query (Maybe a) getDBInfo keyPred key = Query $ do rows <- selectRows keyPred "*" $ "where _rowid_ = " ++ show key readHeadIfExists rows where readHeadIfExists [] = return Nothing readHeadIfExists (x:_) = return $!! Just (readInfo x) --- Queries the information stored under the given keys. Yields --- Nothing if a given key is not present. getDBInfos :: KeyPred a -> [Key] -> Query (Maybe [a]) getDBInfos keyPred keys = Query $ do rows <- selectRows keyPred "_rowid_,*" $ "where _rowid_ in (" ++ commaSep (map show keys) ++ ")" sortByIndexInGivenList rows where sortByIndexInGivenList rows = do keyInfos <- mapIO readKeyInfo rows return $ mapMMaybe (\key -> lookup key keyInfos) keys commaSep :: [String] -> String commaSep = concat . intersperse ", " --- Deletes the information stored under the given key. If the given --- key does not exist this transaction is silently ignored and no --- error is raised. deleteDBEntry :: KeyPred _ -> Key -> Transaction () deleteDBEntry keyPred key = modify keyPred "delete from" $ "where _rowid_ = " ++ show key --- Deletes the information stored under the given keys. No error is --- raised if (some of) the keys do not exist. deleteDBEntries :: KeyPred _ -> [Key] -> Transaction () deleteDBEntries keyPred keys = modify keyPred "delete from" $ "where _rowid_ in (" ++ commaSep (map show keys) ++ ")" --- Updates the information stored under the given key. The --- transaction is aborted with a KeyNotExistsError if --- the given key is not present in the database. updateDBEntry :: KeyPred a -> Key -> a -> Transaction () updateDBEntry keyPred key info = errorUnlessKeyExists keyPred key ("updateDBEntry, " ++ show key) |>> modify keyPred "update" ("set " ++ commaSep (colVals keyPred info) ++ " where _rowid_ = " ++ show key) errorUnlessKeyExists :: KeyPred a -> Key -> String -> Transaction () errorUnlessKeyExists keyPred key msg = getDB (existsDBKey keyPred key) |>>= \exists -> if not exists then errorT $ TError KeyNotExistsError msg else doneT colVals :: KeyPred a -> a -> [String] colVals keyPred info = zipWith (\c v -> c ++ " = " ++ v) (colNames keyPred) (infoVals keyPred info) infoVals :: KeyPred a -> a -> [String] infoVals keyPred info | null . tail $ colNames keyPred = [quote $ showQTerm info] | otherwise = map quote $ showTupleArgs info quote :: String -> String quote s = "'" ++ concatMap quoteChar s ++ "'" where quoteChar c = if c == ''' then "''" else [c] --- Stores new information in the database and yields the newly --- generated key. newDBEntry :: KeyPred a -> a -> Transaction Key newDBEntry keyPred info = modify keyPred "insert into" ("values (" ++ commaSep (infoVals keyPred info) ++ ")") |>> getDB (Query $ selectInt keyPred "last_insert_rowid()" "") --- Stores a new entry in the database under a given key. --- The transaction fails if the key already exists. --- @param db - the database (a dynamic predicate) --- @param key - the key of the new entry (an integer) --- @param info - the information to be stored in the new entry newDBKeyEntry :: KeyPred a -> Key -> a -> Transaction () newDBKeyEntry keyPred key info = getDB (existsDBKey keyPred key) |>>= \b -> if b then errorT . TError DuplicateKeyError $ "database already contains entry with key: " ++ show key else modify keyPred "insert into" ("values (" ++ commaSep (infoVals keyPred info) ++ ")") |>> getDB (Query $ selectInt keyPred "last_insert_rowid()" "") |>>= \k -> modify keyPred "update" $ "set _rowid_ = " ++ show key ++ " where _rowid_ = " ++ show k --- Deletes all entries from the database associated with a predicate. cleanDB :: KeyPred _ -> Transaction () cleanDB keyPred = modify keyPred "delete from" "" -- SQL access functions -- These functions are not exported and abstract common functionality -- used in the library functions above. Each database access is one of -- the following: a modification, a selection of a numeric aggregate, -- or a selection of rows. sqlite3 :: KeyPred _ -> String -> IO Handle sqlite3 keyPred sql = do h <- getDBHandle keyPred hPutAndFlush h $ sql ++ ";" return h hPutAndFlush :: Handle -> String -> IO () hPutAndFlush h s = hPutStrLn h s >> hFlush h modify :: KeyPred _ -> String -> String -> Transaction () modify keyPred before after = transIO $ do sqlite3 keyPred $ before ++ " " ++ tableName keyPred ++ " " ++ after done selectInt :: KeyPred _ -> String -> String -> IO Int selectInt keyPred aggr cond = do h <- sqlite3 keyPred $ "select distinct " ++ aggr ++ " from " ++ tableName keyPred ++ " " ++ cond hGetLine h >>= readIntOrExit -- yields 1 for "1a" and exits for "" readIntOrExit :: String -> IO Int readIntOrExit s = maybe err (return . fst) $ readInt s where err = dbError ExecutionError $ "readIntOrExit: cannot parse integer from string '" ++ show s ++ "'" -- When selecting an unknown number of rows it is necessary to know -- when to stop. One way to be able to stop is to select 'count(*)' -- instead of the actual colums before the query. As it is potentially -- inefficient to execute the query twice, this implementation takes a -- different approach: generate a random string before the query and -- select it afterwards, then read all lines up to this random string. type Row = String selectRows :: KeyPred _ -> String -> String -> IO [Row] selectRows keyPred cols cond = do h <- sqlite3 keyPred "select hex(randomblob(8))" rnd <- hGetLine h -- 8 random bytes = 16 random hex chars hPutAndFlush h $ "select " ++ cols ++ " from " ++ tableName keyPred ++ " " ++ cond ++ "; select " ++ quote rnd ++ ";" hGetLinesBefore h rnd hGetLinesBefore :: Handle -> String -> IO [String] hGetLinesBefore h stop = do line <- hGetLine h if line == stop then return [] else do rest <- hGetLinesBefore h stop return (line : rest) selectSomeRows :: KeyPred _ -> [ColVal] -> String -> IO [Row] selectSomeRows keyPred cvs cols = selectRows keyPred cols $ if null cvs then "" else "where " ++ showColVals keyPred cvs showColVals :: KeyPred a -> [ColVal] -> String showColVals _ [] = "1" showColVals keyPred (c:vs) = concat . intersperse " AND " $ map showCV (c:vs) where showCV (ColVal n s) = colNames keyPred !! n ++ " = " ++ s --- Closes all database connections. Should be called when no more --- database access will be necessary. closeDBHandles :: IO () closeDBHandles = do withAllDBHandles hClose writeGlobal openDBHandles [] -- helper functions and globaly stored information dbError :: TErrorKind -> String -> IO a dbError kind msg = do writeGlobal lastQueryError . Just $ TError kind msg error msg lastQueryError :: Global (Maybe TError) lastQueryError = global Nothing Temporary getDBHandle :: KeyPred _ -> IO Handle getDBHandle keyPred = do ensureDBFor keyPred readDBHandle $ dbFile keyPred -- Initializes the database and table for the given predicate. This -- function must be called before the database for this predicate is -- accessed and before a transaction that uses this predicate is -- started. ensureDBFor :: KeyPred _ -> IO () ensureDBFor keyPred = do ensureDBHandle db ensureDBTable db table cols where (db,(table,cols)) = dbInfo keyPred readDBHandle :: DBFile -> IO Handle readDBHandle db = readGlobal openDBHandles >>= maybe err return . lookup db where err = dbError ExecutionError $ "readDBHandle: no handle for '" ++ db ++ "'" openDBHandles :: Global [(DBFile,Handle)] openDBHandles = global [] Temporary withAllDBHandles :: (Handle -> IO _) -> IO () withAllDBHandles f = do dbHandles <- readGlobal openDBHandles mapIO_ (f . snd) dbHandles ensureDBHandle :: DBFile -> IO () ensureDBHandle db = do dbHandles <- readGlobal openDBHandles unless (db `elem` map fst dbHandles) $ addNewDBHandle dbHandles where addNewDBHandle dbHandles = do exsqlite3 <- system $ "which " ++ path'to'sqlite3 ++ " > /dev/null" when (exsqlite3>0) $ error "Database interface `sqlite3' not found. Please install package `sqlite3'!" h <- connectToCommand $ path'to'sqlite3 ++ " " ++ db hPutAndFlush h ".separator ','" writeGlobal openDBHandles $ -- sort against deadlock insertBy ((<=) `on` fst) (db,h) dbHandles isTrans <- readGlobal currentlyInTransaction unless (not isTrans) $ hPutStrLn h "begin immediate;" unless :: Bool -> IO () -> IO () unless False action = action unless True _ = done on :: (b -> b -> c) -> (a -> b) -> a -> a -> c on f g x y = f (g x) (g y) ensureDBTable :: DBFile -> TableName -> [ColName] -> IO () ensureDBTable db table cols = do dbTables <- readGlobal knownDBTables unless ((db,table) `elem` dbTables) $ do h <- readDBHandle db hPutAndFlush h $ "create table if not exists " ++ table ++ " (" ++ commaSep cols ++ ");" writeGlobal knownDBTables $ (db,table) : dbTables knownDBTables :: Global [(DBFile,TableName)] knownDBTables = global [] Temporary beginTransaction :: IO () beginTransaction = do writeGlobal currentlyInTransaction True withAllDBHandles (`hPutAndFlush` "begin immediate;") commitTransaction :: IO () commitTransaction = do withAllDBHandles (`hPutAndFlush` "commit;") writeGlobal currentlyInTransaction False rollbackTransaction :: IO () rollbackTransaction = do withAllDBHandles (`hPutAndFlush` "rollback;") writeGlobal currentlyInTransaction False currentlyInTransaction :: Global Bool currentlyInTransaction = global False Temporary -- converting arguments of a tuple to strings showTupleArgs :: a -> [String] showTupleArgs = splitTLC . removeOuterParens . showQTerm removeOuterParens :: String -> String removeOuterParens ('(':cs) = init cs init :: [a] -> [a] init = reverse . tail . reverse -- split at top-level commas splitTLC :: String -> [String] splitTLC = parse "" type Stack = String parse :: Stack -> String -> [String] parse _ "" = [] parse st (c:cs) = case (st,c:cs) of -- Curry allows ''' for '\'' ('\'':xs,'\'':'\'':ys) -> '\'' <: ('\'' <: parse xs ys) _ -> next c st $ parse (updStack c st) cs next :: Char -> Stack -> [String] -> [String] next c [] xs = if c==',' then [] : xs else c <: xs next c (_:_) xs = c <: xs (<:) :: Char -> [String] -> [String] c <: [] = [[c]] c <: (x:xs) = (c:x):xs updStack :: Char -> Stack -> Stack updStack char stack = case (char,stack) of -- char is an escaped character (_ ,'\\':xs) -> xs -- the next character is not -- char is the escape character ('\\', xs) -> '\\':xs -- push it on the stack -- char is the string terminator ('"' , '"':xs) -> xs -- closes current string literal ('"' , ''':xs) -> ''':xs -- ignored inside character ('"' , xs) -> '"':xs -- opens a new string -- char is the character terminator (''' , ''':xs) -> xs -- closes current character literal (''' , '"':xs) -> '"':xs -- ignored inside string (''' , xs) -> ''':xs -- opens a new character -- parens and brackets (_ , '"':xs) -> '"':xs -- are ignored inside strings (_ , ''':xs) -> ''':xs -- and characters ('(' , xs) -> '(':xs -- new opening paren (')' , '(':xs) -> xs -- closing paren ('[' , xs) -> '[':xs -- opening bracket (']' , '[':xs) -> xs -- closing bracket -- other characters don't modify the stack (_ , xs) -> xs -- for debugging -- hPutStrLn h s = -- do IO.hPutStrLn stderr $ " > " ++ s -- IO.hPutStrLn h s -- hGetLine h = -- do l <- IO.hGetLine h -- IO.hPutStrLn stderr $ "< " ++ l -- return l -- copied from Database: --- The type of errors that might occur during a transaction. data TError = TError TErrorKind String --- The various kinds of transaction errors. data TErrorKind = KeyNotExistsError | NoRelationshipError | DuplicateKeyError | KeyRequiredError | UniqueError | MinError | MaxError | UserDefinedError | ExecutionError --- Transforms a transaction error into a string. showTError :: TError -> String showTError (TError k s) = "Transaction error " ++ show k ++ ": " ++ s curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/LICENSE000066400000000000000000000027101305333611600222350ustar00rootroot00000000000000Copyright (c) 2011-2016, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - None of the names of the copyright holders and contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/List.curry000066400000000000000000000325341305333611600232400ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library with some useful operations on lists. --- --- @author Michael Hanus, Bjoern Peemoeller --- @version Februar 2016 --- @category general ------------------------------------------------------------------------------ {-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-} module List ( elemIndex, elemIndices, find, findIndex, findIndices , nub, nubBy, delete, deleteBy, (\\), union, intersect , intersperse, intercalate, transpose, diagonal, permutations, partition , group, groupBy, splitOn, split, inits, tails, replace , isPrefixOf, isSuffixOf, isInfixOf , sortBy, insertBy , unionBy, intersectBy , last, init , sum, product, maximum, minimum, maximumBy, minimumBy , scanl, scanl1, scanr, scanr1 , mapAccumL, mapAccumR , cycle, unfoldr ) where import Maybe (listToMaybe) infix 5 \\ --- Returns the index `i` of the first occurrence of an element in a list --- as `(Just i)`, otherwise `Nothing` is returned. elemIndex :: a -> [a] -> Maybe Int elemIndex x = findIndex (x ==) --- Returns the list of indices of occurrences of an element in a list. elemIndices :: a -> [a] -> [Int] elemIndices x = findIndices (x ==) --- Returns the first element `e` of a list satisfying a predicate as `(Just e)`, --- otherwise `Nothing` is returned. find :: (a -> Bool) -> [a] -> Maybe a find p = listToMaybe . filter p --- Returns the index `i` of the first occurrences of a list element --- satisfying a predicate as `(Just i)`, otherwise `Nothing` is returned. findIndex :: (a -> Bool) -> [a] -> Maybe Int findIndex p = listToMaybe . findIndices p --- Returns the list of indices of list elements satisfying a predicate. findIndices :: (a -> Bool) -> [a] -> [Int] findIndices p xs = [ i | (x,i) <- zip xs [0..], p x ] --- Removes all duplicates in the argument list. nub :: [a] -> [a] nub xs = nubBy (==) xs --- Removes all duplicates in the argument list according to an --- equivalence relation. nubBy :: (a -> a -> Bool) -> [a] -> [a] nubBy _ [] = [] nubBy eq (x:xs) = x : nubBy eq (filter (\y -> not (eq x y)) xs) --- Deletes the first occurrence of an element in a list. delete :: a -> [a] -> [a] delete = deleteBy (==) --- Deletes the first occurrence of an element in a list --- according to an equivalence relation. deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a] deleteBy _ _ [] = [] deleteBy eq x (y:ys) = if eq x y then ys else y : deleteBy eq x ys --- Computes the difference of two lists. --- @param xs - a list --- @param ys - a list --- @return the list where the first occurrence of each element of --- `ys` has been removed from `xs` (\\) :: [a] -> [a] -> [a] xs \\ ys = foldl (flip delete) xs ys --- Computes the union of two lists. union :: [a] -> [a] -> [a] union [] ys = ys union (x:xs) ys = if x `elem` ys then union xs ys else x : union xs ys --- Computes the union of two lists according to the given equivalence relation unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs --- Computes the intersection of two lists. intersect :: [a] -> [a] -> [a] intersect [] _ = [] intersect (x:xs) ys = if x `elem` ys then x : intersect xs ys else intersect xs ys --- Computes the intersection of two lists --- according to the given equivalence relation intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] intersectBy _ [] _ = [] intersectBy _ (_:_) [] = [] intersectBy eq xs@(_:_) ys@(_:_) = [x | x <- xs, any (eq x) ys] --- Puts a separator element between all elements in a list. --- --- Example: `(intersperse 9 [1,2,3,4]) = [1,9,2,9,3,9,4]` intersperse :: a -> [a] -> [a] intersperse _ [] = [] intersperse _ [x] = [x] intersperse sep (x:xs@(_:_)) = x : sep : intersperse sep xs --- `intercalate xs xss` is equivalent to `(concat (intersperse xs xss))`. --- It inserts the list `xs` in between the lists in `xss` and --- concatenates the result. intercalate :: [a] -> [[a]] -> [a] intercalate xs xss = concat (intersperse xs xss) --- Transposes the rows and columns of the argument. --- --- Example: `(transpose [[1,2,3],[4,5,6]]) = [[1,4],[2,5],[3,6]]` transpose :: [[a]] -> [[a]] transpose [] = [] transpose ([] : xss) = transpose xss transpose ((x:xs) : xss) = (x : map head xss) : transpose (xs : map tail xss) --- Diagonalization of a list of lists. --- Fairly merges (possibly infinite) list of (possibly infinite) lists. --- --- @param xss - lists of lists --- @return fair enumeration of all elements of inner lists of given lists --- diagonal :: [[a]] -> [a] diagonal = concat . foldr diags [] where diags [] ys = ys diags (x:xs) ys = [x] : merge xs ys merge [] ys = ys merge xs@(_:_) [] = map (:[]) xs merge (x:xs) (y:ys) = (x:y) : merge xs ys --- Returns the list of all permutations of the argument. permutations :: [a] -> [[a]] permutations xs0 = xs0 : perms xs0 [] where perms [] _ = [] perms (t:ts) is = foldr interleave (perms ts (t:is)) (permutations is) where interleave xs r = let (_, zs) = interleave' id xs r in zs interleave' _ [] r = (ts, r) interleave' f (y:ys) r = let (us, zs) = interleave' (f . (y:)) ys r in (y:us, f (t:y:us) : zs) --- Partitions a list into a pair of lists where the first list --- contains those elements that satisfy the predicate argument --- and the second list contains the remaining arguments. --- --- Example: `(partition (<4) [8,1,5,2,4,3]) = ([1,2,3],[8,5,4])` partition :: (a -> Bool) -> [a] -> ([a],[a]) partition p xs = foldr select ([],[]) xs where select x (ts,fs) = if p x then (x:ts,fs) else (ts,x:fs) --- Splits the list argument into a list of lists of equal adjacent --- elements. --- --- Example: `(group [1,2,2,3,3,3,4]) = [[1],[2,2],[3,3,3],[4]]` group :: [a] -> [[a]] group = groupBy (==) --- Splits the list argument into a list of lists of related adjacent --- elements. --- @param eq - the relation to classify adjacent elements --- @param xs - the list of elements --- @return the list of lists of related adjacent elements groupBy :: (a -> a -> Bool) -> [a] -> [[a]] groupBy _ [] = [] groupBy eq (x:xs) = (x:ys) : groupBy eq zs where (ys,zs) = span (eq x) xs --- Breaks the second list argument into pieces separated by the first --- list argument, consuming the delimiter. An empty delimiter is --- invalid, and will cause an error to be raised. splitOn :: [a] -> [a] -> [[a]] splitOn [] _ = error "splitOn called with an empty pattern" splitOn [x] xs = split (x ==) xs splitOn sep@(_:_:_) xs = go xs where go [] = [[]] go l@(y:ys) | sep `isPrefixOf` l = [] : go (drop len l) | otherwise = let (zs:zss) = go ys in (y:zs):zss len = length sep --- Splits a list into components delimited by separators, --- where the predicate returns True for a separator element. --- The resulting components do not contain the separators. --- Two adjacent separators result in an empty component in the output. --- --- > split (=='a') "aabbaca" == ["","","bb","c",""] --- > split (=='a') "" == [""] split :: (a -> Bool) -> [a] -> [[a]] split _ [] = [[]] split p (x:xs) | p x = [] : split p xs | otherwise = let (ys:yss) = split p xs in (x:ys):yss --- Returns all initial segments of a list, starting with the shortest. --- Example: `inits [1,2,3] == [[],[1],[1,2],[1,2,3]]` --- @param xs - the list of elements --- @return the list of initial segments of the argument list inits :: [a] -> [[a]] inits [] = [[]] inits (x:xs) = [] : map (x:) (inits xs) --- Returns all final segments of a list, starting with the longest. --- Example: `tails [1,2,3] == [[1,2,3],[2,3],[3],[]]` tails :: [a] -> [[a]] tails [] = [[]] tails xxs@(_:xs) = xxs : tails xs --- Replaces an element in a list. --- @param x - the new element --- @param p - the position of the new element (head = 0) --- @param ys - the old list --- @return the new list where the `p`. element is replaced by `x` replace :: a -> Int -> [a] -> [a] replace _ _ [] = [] replace x p (y:ys) | p==0 = x:ys | otherwise = y:(replace x (p-1) ys) --- Checks whether a list is a prefix of another. --- @param xs - a list --- @param ys - a list --- @return `True` if `xs` is a prefix of `ys` isPrefixOf :: [a] -> [a] -> Bool isPrefixOf [] _ = True isPrefixOf (_:_) [] = False isPrefixOf (x:xs) (y:ys) = x==y && (isPrefixOf xs ys) --- Checks whether a list is a suffix of another. --- @param xs - a list --- @param ys - a list --- @return `True` if `xs` is a suffix of `ys` isSuffixOf :: [a] -> [a] -> Bool isSuffixOf xs ys = isPrefixOf (reverse xs) (reverse ys) --- Checks whether a list is contained in another. --- @param xs - a list --- @param ys - a list --- @return True if xs is contained in ys isInfixOf :: [a] -> [a] -> Bool isInfixOf xs ys = any (isPrefixOf xs) (tails ys) --- Sorts a list w.r.t. an ordering relation by the insertion method. sortBy :: (a -> a -> Bool) -> [a] -> [a] sortBy le = foldr (insertBy le) [] --- Inserts an object into a list according to an ordering relation. --- @param le - an ordering relation (e.g., less-or-equal) --- @param x - an element --- @param xs - a list --- @return a list where the element has been inserted insertBy :: (a -> a -> Bool) -> a -> [a] -> [a] insertBy _ x [] = [x] insertBy le x (y:ys) = if le x y then x : y : ys else y : insertBy le x ys --- Returns the last element of a non-empty list. last :: [a] -> a last [x] = x last (_ : xs@(_:_)) = last xs --- Returns the input list with the last element removed. init :: [a] -> [a] init [_] = [] init (x:xs@(_:_)) = x : init xs --- Returns the sum of a list of integers. sum :: [Int] -> Int sum ns = foldl (+) 0 ns --- Returns the product of a list of integers. product :: [Int] -> Int product ns = foldl (*) 1 ns --- Returns the maximum of a non-empty list. maximum :: [a] -> a maximum xs@(_:_) = foldl1 max xs --- Returns the maximum of a non-empty list --- according to the given comparison function maximumBy :: (a -> a -> Ordering) -> [a] -> a maximumBy cmp xs@(_:_) = foldl1 maxBy xs where maxBy x y = case cmp x y of GT -> x _ -> y --- Returns the minimum of a non-empty list. minimum :: [a] -> a minimum xs@(_:_) = foldl1 min xs --- Returns the minimum of a non-empty list --- according to the given comparison function minimumBy :: (a -> a -> Ordering) -> [a] -> a minimumBy cmp xs@(_:_) = foldl1 minBy xs where minBy x y = case cmp x y of GT -> y _ -> x --- `scanl` is similar to `foldl`, but returns a list of successive --- reduced values from the left: --- scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] scanl :: (a -> b -> a) -> a -> [b] -> [a] scanl f q ls = q : (case ls of [] -> [] x:xs -> scanl f (f q x) xs) --- `scanl1` is a variant of `scanl` that has no starting value argument: --- scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] scanl1 :: (a -> a -> a) -> [a] -> [a] scanl1 _ [] = [] scanl1 f (x:xs) = scanl f x xs --- `scanr` is the right-to-left dual of `scanl`. scanr :: (a -> b -> b) -> b -> [a] -> [b] scanr _ q0 [] = [q0] scanr f q0 (x:xs) = f x q : qs where qs@(q:_) = scanr f q0 xs --- `scanr1` is a variant of `scanr` that has no starting value argument. scanr1 :: (a -> a -> a) -> [a] -> [a] scanr1 _ [] = [] scanr1 _ [x] = [x] scanr1 f (x:xs@(_:_)) = f x q : qs where qs@(q:_) = scanr1 f xs --- The `mapAccumL` function behaves like a combination of `map` and --- `foldl`; it applies a function to each element of a list, passing --- an accumulating parameter from left to right, and returning a final --- value of this accumulator together with the new list. mapAccumL :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y]) mapAccumL _ s [] = (s, []) mapAccumL f s (x:xs) = (s'',y:ys) where (s', y ) = f s x (s'',ys) = mapAccumL f s' xs --- The `mapAccumR` function behaves like a combination of `map` and --- `foldr`; it applies a function to each element of a list, passing --- an accumulating parameter from right to left, and returning a final --- value of this accumulator together with the new list. mapAccumR :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y]) mapAccumR _ s [] = (s, []) mapAccumR f s (x:xs) = (s'', y:ys) where (s'',y ) = f s' x (s', ys) = mapAccumR f s xs --- Builds an infinite list from a finite one. cycle :: [a] -> [a] cycle xs@(_:_) = ys where ys = xs ++ ys --- Builds a list from a seed value. unfoldr :: (b -> Maybe (a, b)) -> b -> [a] unfoldr f b = case f b of Just (a, new_b) -> a : unfoldr f new_b Nothing -> [] curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Mail.curry000066400000000000000000000052111305333611600231770ustar00rootroot00000000000000--------------------------------------------------------------------------- --- This library contains functions for sending emails. --- The implementation might need to be adapted to the local --- environment. --- --- @author Michael Hanus --- @version May 2007 --- @category web --------------------------------------------------------------------------- module Mail(sendMail,MailOption(..),sendMailWithOptions) where import List(intersperse) import IOExts(execCmd) import IO(hPutStrLn,hClose) --- Sends an email via mailx command. --- @param from - the email address of the sender --- @param to - the email address of the recipient --- @param subject - the subject of the email --- @param contents - the contents of the email sendMail :: String -> String -> String -> String -> IO () sendMail from to subject = sendMailWithOptions from subject [TO to] --- Options for sending emails. --- @cons CC - recipient of a carbon copy --- @cons BCC - recipient of a blind carbon copy --- @cons TO - recipient of the email data MailOption = CC String | BCC String | TO String --- Sends an email via mailx command and various options. --- Note that multiple options are allowed, e.g., more than one CC option --- for multiple recipient of carbon copies. --- --- Important note: The implementation of this operation is based on the --- command "mailx" and must be adapted according to your local environment! --- --- @param from - the email address of the sender --- @param subject - the subject of the email --- @param options - send options, e.g., multiple recipients --- @param contents - the contents of the email sendMailWithOptions :: String -> String -> [MailOption] -> String -> IO () sendMailWithOptions from subject options contents = do -- if mailx has the option -r: --execMailCmd ("mailx -n -r \""++from++"\" -s \""++subject++"\" "++ -- if mailx has the option -a: execMailCmd ("mailx -n -a \"From: "++from++"\" -s \""++subject++"\" "++ (if null bccs then "" else "-b \""++bccs++"\" ") ++ (if null ccs then "" else "-c \""++ccs++"\" ") ++"\""++tos++"\"") contents where tos = concat (intersperse " " [ s | TO s <- options ]) ccs = concat (intersperse " " [ s | CC s <- options ]) bccs = concat (intersperse " " [ s | BCC s <- options ]) --- Executes a command to send an email and pass the contents via stdin. --- Note that \r characters in the contents are removed due to problems --- with such contents in some Unix environments. execMailCmd :: String -> String -> IO () execMailCmd cmd contents = do (sin,_,_) <- execCmd cmd hPutStrLn sin (filter isUnixChar contents) hClose sin where isUnixChar c = c /= '\r' curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Makefile.kics2000066400000000000000000000263721305333611600237140ustar00rootroot00000000000000# Makefile for various compilations of the system libraries, # in particular, to generate the documentation CYMAKEPARAMS = --extended -Wnone -i. KICS2=$(ROOT)/bin/kics2 # directory for HTML documentation files # LIBDOCDIR = $(DOCDIR)/html LIBDOCDIR := CDOC # directory for LaTeX documentation files TEXDOCDIR := $(DOCDIR)/src/lib # replacement stuff comma := , empty := space := $(empty) $(empty) # prefix "pre" "dir/file.ext" = "dir/prefile.ext" prefix = $(patsubst ./%,%,$(dir $(2))$(1)$(notdir $(2))) # comma_sep "a b c" = "a, b, c" comma_sep = $(subst $(space),$(comma)$(space),$(1)) # Curry library files LIB_CURRY = $(filter-out $(EXCLUDES), $(wildcard *.curry AbstractCurry/*.curry FlatCurry/*.curry FlatCurry/Annotated/*.curry Database/*.curry Database/CDBI/*.curry Rewriting/*.curry Test/*.curry)) # lib names without directory prefix LIB_NAMES = $(subst /,., $(basename $(LIB_CURRY))) # lib names included in library documentation page (without directory prefix) LIB_DOCNAMES = $(filter-out $(DOCEXCLUDES), $(LIB_NAMES)) # Generated files LIB_FCY = $(foreach lib, $(LIB_CURRY:%.curry=.curry/%.fcy), $(lib)) LIB_ACY = $(foreach lib, $(LIB_CURRY:%.curry=.curry/%.acy), $(lib)) LIB_HS = $(foreach lib, $(LIB_CURRY:.curry=.hs), .curry/kics2/$(call prefix,Curry_,$(lib))) LIB_HS_TRACE = $(foreach lib, $(LIB_CURRY:.curry=.hs), .curry/kics2/$(call prefix,Curry_Trace_,$(lib))) LIB_HTML = $(foreach lib, $(LIB_CURRY:.curry=.html), $(LIBDOCDIR)/$(subst /,.,$(lib))) LIB_TEX = $(foreach lib, $(LIB_CURRY:.curry=.tex), $(TEXDOCDIR)/$(subst /,.,$(lib))) HS_LIB_NAMES = $(call comma_sep,$(foreach lib,$(LIB_NAMES),$(if $(findstring .,$(lib)),$(basename $(lib)).Curry_$(subst .,,$(suffix $(lib))),Curry_$(lib)))) HS_LIB_TRACE_NAMES = $(call comma_sep,$(foreach lib,$(LIB_NAMES),$(if $(findstring .,$(lib)),$(basename $(lib)).Curry_Trace_$(subst .,,$(suffix $(lib))),Curry_Trace_$(lib)))) ALLLIBS = AllLibraries MAINGOAL = Curry_Main_Goal.curry # Modules not included as regular libraries: EXCLUDES = $(ALLLIBS).curry $(MAINGOAL) # Modules not included in library documentation index page: DOCEXCLUDES = CPNS HtmlCgi ValueSequence WUIjs PACKAGE = kics2-libraries PACKAGE_TRACE = kics2-libraries-trace CABAL_FILE = $(PACKAGE).cabal CABAL_TRACE_FILE = $(PACKAGE_TRACE).cabal CABAL_LIBDEPS = $(call comma_sep,$(LIBDEPS)) ######################################################################## # support for installation ######################################################################## .PHONY: install install: fcy acy hs hstrace $(MAKE) $(CABAL_FILE) $(CABAL_INSTALL) $(CABAL_PROFILE) rm -f $(CABAL_FILE) $(MAKE) $(CABAL_TRACE_FILE) $(CABAL_INSTALL) $(CABAL_PROFILE) rm -f $(CABAL_TRACE_FILE) # create a program importing all libraries in order to re-compile them # so that all auxiliary files (.nda, .hs, ...) are up-to-date $(ALLLIBS).curry: $(LIB_CURRY) Makefile rm -f $@ for i in $(filter-out Prelude, $(LIB_NAMES)) ; do echo "import $$i" >> $@ ; done .PHONY: allsources allsources: @echo $(LIB_CURRY) .PHONY: unregister unregister: -$(GHC_UNREGISTER) $(PACKAGE)-$(VERSION) -$(GHC_UNREGISTER) $(PACKAGE_TRACE)-$(VERSION) # clean Haskell intermediate files .PHONY: clean: -cd .curry/kics2 && rm -f *.hi *.o # clean all generated files .PHONY: cleanall cleanall: rm -rf "$(LIBDOCDIR)" rm -rf "$(TEXDOCDIR)" rm -rf dist rm -f $(CABAL_FILE) rm -f $(CABAL_TRACE_FILE) rm -fr .curry $(CABAL_FILE): ../Makefile Makefile echo "Name: $(PACKAGE)" > $@ echo "Version: $(VERSION)" >> $@ echo "Description: The standard libraries for KiCS2" >> $@ echo "License: OtherLicense" >> $@ echo "Author: The KiCS2 Team" >> $@ echo "Maintainer: kics2@curry-language.org" >> $@ echo "Build-Type: Simple" >> $@ echo "Cabal-Version: >= 1.9.2" >> $@ echo "" >> $@ echo "Library" >> $@ echo " Build-Depends:" >> $@ echo " kics2-runtime == $(VERSION)" >> $@ echo " , $(CABAL_LIBDEPS)" >> $@ echo " if os(windows)" >> $@ echo " Build-Depends: Win32" >> $@ echo " else" >> $@ echo " Build-Depends: unix" >> $@ echo " Exposed-modules: $(HS_LIB_NAMES)" >> $@ echo " hs-source-dirs: ./.curry/kics2" >> $@ $(CABAL_TRACE_FILE): ../Makefile Makefile echo "Name: $(PACKAGE_TRACE)" > $@ echo "Version: $(VERSION)" >> $@ echo "Description: The tracing standard libraries for KiCS2" >> $@ echo "License: OtherLicense" >> $@ echo "Author: The KiCS2 Team" >> $@ echo "Maintainer: kics2@curry-language.org" >> $@ echo "Build-Type: Simple" >> $@ echo "Cabal-Version: >= 1.9.2" >> $@ echo "" >> $@ echo "Library" >> $@ echo " Build-Depends:" >> $@ echo " kics2-runtime == $(VERSION)" >> $@ echo " , $(CABAL_LIBDEPS)" >> $@ echo " if os(windows)" >> $@ echo " Build-Depends: Win32" >> $@ echo " else" >> $@ echo " Build-Depends: unix" >> $@ echo " Exposed-modules: $(HS_LIB_TRACE_NAMES)" >> $@ echo " hs-source-dirs: ./.curry/kics2" >> $@ # generate the compiled Haskell target files of all libraries: .NOTPARALLEL: hs .PHONY: hs hs: .curry/kics2/Curry_$(ALLLIBS).hs $(LIB_HS) # generate the compiled Haskell target files with tracing of all libraries: .NOTPARALLEL: hstrace .PHONY: hstrace hs: $(LIB_HS_TRACE) # generate Haskell file in subdirectory .curry/kics2 .curry/kics2/Curry_Trace_%.hs: %.curry $(COMP) -v0 -i. --trace-failure $* .curry/kics2/Curry_%.hs: %.curry $(COMP) -v0 -i. $* .curry/kics2/AbstractCurry/Curry_Trace_%.hs: AbstractCurry/%.curry $(COMP) -v0 -i. --trace-failure AbstractCurry.$* .curry/kics2/AbstractCurry/Curry_%.hs: AbstractCurry/%.curry $(COMP) -v0 -i. AbstractCurry.$* .curry/kics2/FlatCurry/Annotated/Curry_Trace_%.hs: FlatCurry/Annotated/%.curry $(COMP) -v0 -i. --trace-failure FlatCurry.Annotated.$* .curry/kics2/FlatCurry/Annotated/Curry_%.hs: FlatCurry/Annotated/%.curry $(COMP) -v0 -i. FlatCurry.Annotated.$* .curry/kics2/FlatCurry/Curry_Trace_%.hs: FlatCurry/%.curry $(COMP) -v0 -i. --trace-failure FlatCurry.$* .curry/kics2/FlatCurry/Curry_%.hs: FlatCurry/%.curry $(COMP) -v0 -i. FlatCurry.$* .curry/kics2/Database/CDBI/Curry_Trace_%.hs: Database/CDBI/%.curry $(COMP) -v0 -i. --trace-failure Database.CDBI.$* .curry/kics2/Database/CDBI/Curry_%.hs: Database/CDBI/%.curry $(COMP) -v0 -i. Database.CDBI.$* .curry/kics2/Database/Curry_Trace_%.hs: Database/%.curry $(COMP) -v0 -i. --trace-failure Database.$* .curry/kics2/Database/Curry_%.hs: Database/%.curry $(COMP) -v0 -i. Database.$* .curry/kics2/Rewriting/Curry_Trace_%.hs: Rewriting/%.curry $(COMP) -v0 -i. --trace-failure Rewriting.$* .curry/kics2/Rewriting/Curry_%.hs: Rewriting/%.curry $(COMP) -v0 -i. Rewriting.$* .curry/kics2/Test/Curry_Trace_%.hs: Test/%.curry $(COMP) -v0 -i. --trace-failure Test.$* .curry/kics2/Test/Curry_%.hs: Test/%.curry $(COMP) -v0 -i. Test.$* # generate the FlatCurry files of all libraries: .NOTPARALLEL: fcy .PHONY: fcy fcy: $(LIB_FCY) # generate FlatCurry file in subdirectory .curry: .curry/%.fcy: %.curry "$(CYMAKE)" --flat $(CYMAKEPARAMS) $(subst /,.,$*) # generate the AbstractCurry files of all libraries: .PHONY: acy acy: $(LIB_ACY) # generate AbstractCurry file in subdirectory .curry: .curry/%.acy: %.curry "$(CYMAKE)" --acy $(CYMAKEPARAMS) $(subst /,.,$*) ############################################################################## # create HTML documentation files for system libraries ############################################################################## INDEXHTML = $(LIBDOCDIR)/index.html HTMLEXCLUDES = $(INDEXHTML) $(foreach file, findex.html cindex.html KiCS2_libs.html, $(LIBDOCDIR)/$(file)) .PHONY: doc doc: $(LIB_CURRY) @mkdir -p "$(LIBDOCDIR)" @$(MAKE) $(LIB_HTML) @$(MAKE) $(INDEXHTML) $(INDEXHTML): $(filter-out $(HTMLEXCLUDES), $(wildcard $(LIBDOCDIR)/*.html)) @echo "Generating index pages for Curry libraries:" @echo $(LIB_DOCNAMES) "$(KICS2)" doc --libsindexhtml "$(LIBDOCDIR)" $(LIB_DOCNAMES) # generate individual documentations for libraries $(LIBDOCDIR)/AbstractCurry.%.html: AbstractCurry/%.curry "$(KICS2)" doc --noindexhtml "$(LIBDOCDIR)" $(subst /,.,$<) $(LIBDOCDIR)/FlatCurry.Annotated.%.html: FlatCurry/Annotated/%.curry "$(KICS2)" doc --noindexhtml "$(LIBDOCDIR)" $(subst /,.,$<) $(LIBDOCDIR)/FlatCurry.%.html: FlatCurry/%.curry "$(KICS2)" doc --noindexhtml "$(LIBDOCDIR)" $(subst /,.,$<) $(LIBDOCDIR)/CLP.%.html: CLP/%.curry "$(KICS2)" doc --noindexhtml "$(LIBDOCDIR)" $(subst /,.,$<) $(LIBDOCDIR)/Database.CDBI.%.html: Database/CDBI/%.curry "$(KICS2)" doc --noindexhtml "$(LIBDOCDIR)" $(subst /,.,$<) $(LIBDOCDIR)/Database.%.html: Database/%.curry "$(KICS2)" doc --noindexhtml "$(LIBDOCDIR)" $(subst /,.,$<) $(LIBDOCDIR)/Rewriting.%.html: Rewriting/%.curry "$(KICS2)" doc --noindexhtml "$(LIBDOCDIR)" $(subst /,.,$<) $(LIBDOCDIR)/Test.%.html: Test/%.curry "$(KICS2)" doc --noindexhtml "$(LIBDOCDIR)" $(subst /,.,$<) $(LIBDOCDIR)/%.html: %.curry "$(KICS2)" doc --noindexhtml "$(LIBDOCDIR)" $(subst /,.,$<) ############################################################################## # create LaTeX documentation files for system libraries ############################################################################## .PHONY: texdoc texdoc: $(LIB_CURRY) @mkdir -p "$(TEXDOCDIR)" $(MAKE) $(LIB_TEX) # generate individual LaTeX documentations for libraries $(TEXDOCDIR)/AbstractCurry.%.tex: AbstractCurry/%.curry "$(KICS2)" doc --tex "$(TEXDOCDIR)" $(subst /,.,$<) $(TEXDOCDIR)/FlatCurry.Annotated.%.tex: FlatCurry/Annotated/%.curry "$(KICS2)" doc --tex "$(TEXDOCDIR)" $(subst /,.,$<) $(TEXDOCDIR)/FlatCurry.%.tex: FlatCurry/%.curry "$(KICS2)" doc --tex "$(TEXDOCDIR)" $(subst /,.,$<) $(TEXDOCDIR)/CLP.%.tex: CLP/%.curry "$(KICS2)" doc --tex "$(TEXDOCDIR)" $(subst /,.,$<) $(TEXDOCDIR)/Database.CDBI.%.tex: Database/CDBI/%.curry "$(KICS2)" doc --tex "$(TEXDOCDIR)" $(subst /,.,$<) $(TEXDOCDIR)/Database.%.tex: Database/%.curry "$(KICS2)" doc --tex "$(TEXDOCDIR)" $(subst /,.,$<) $(TEXDOCDIR)/Rewriting.%.tex: Rewriting/%.curry "$(KICS2)" doc --tex "$(TEXDOCDIR)" $(subst /,.,$<) $(TEXDOCDIR)/Test.%.tex: Test/%.curry "$(KICS2)" doc --tex "$(TEXDOCDIR)" $(subst /,.,$<) $(TEXDOCDIR)/%.tex: %.curry "$(KICS2)" doc --tex "$(TEXDOCDIR)" $(subst /,.,$<) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Makefile.kics2.install000066400000000000000000000031611305333611600253500ustar00rootroot00000000000000# directory containing the repository library files: ifndef CURRYLIBSDIR CURRYLIBSDIR=$(ROOT)/lib-trunk endif # get all library files from standard makefile: LIB_CURRY = `cd $(CURRYLIBSDIR) && $(MAKE) --no-print-directory --quiet -f Makefile.$(CURRYSYSTEM) allsources` # name of this makefile: CURRENT_MAKEFILE = $(CURRYLIBSDIR)/Makefile.$(CURRYSYSTEM).install ########################################################################## # Install the library sources into the Curry system library directory: .PHONY: install install: mkdir -p $(LIBDIR) mkdir -p $(LIBDIR)/AbstractCurry mkdir -p $(LIBDIR)/FlatCurry/Annotated mkdir -p $(LIBDIR)/Database/CDBI mkdir -p $(LIBDIR)/Rewriting mkdir -p $(LIBDIR)/Test $(MAKE) -f $(CURRENT_MAKEFILE) $(LIBDIR)/Makefile $(LIBDIR)/test.sh cd $(LIBDIR) && $(MAKE) -f $(CURRENT_MAKEFILE) sources $(LIBDIR)/Makefile: Makefile.$(CURRYSYSTEM) cp $< $@ $(LIBDIR)/test.sh: test.sh cp $< $@ .PHONY: sources sources: @echo LIB_CURRY=$(LIB_CURRY) $(MAKE) -f $(CURRENT_MAKEFILE) $(LIB_CURRY) cp -p $(CURRYLIBSDIR)/*.hs . AbstractCurry/%.curry: $(CURRYLIBSDIR)/AbstractCurry/%.curry cp $< $@ FlatCurry/Annotated/%.curry: $(CURRYLIBSDIR)/FlatCurry/Annotated/%.curry cp $< $@ FlatCurry/%.curry: $(CURRYLIBSDIR)/FlatCurry/%.curry cp $< $@ Database/CDBI/%.curry: $(CURRYLIBSDIR)/Database/CDBI/%.curry cp $< $@ Database/%.curry: $(CURRYLIBSDIR)/Database/%.curry cp $< $@ Rewriting/%.curry: $(CURRYLIBSDIR)/Rewriting/%.curry cp $< $@ Test/%.curry: $(CURRYLIBSDIR)/Test/%.curry cp $< $@ %.curry: $(CURRYLIBSDIR)/%.curry cp $< $@ index.html: $(CURRYLIBSDIR)/index.html.$(CURRYSYSTEM) cp $< $@ curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Makefile.pakcs000066400000000000000000000137471305333611600240040ustar00rootroot00000000000000# Makefile for various compilations of the system libraries, # in particular, to generate the documentation CYMAKEPARAMS = --extended -Wnone -i. PAKCS=$(ROOT)/bin/pakcs # directory for HTML documentation files: LIBDOCDIR=CDOC # directory for LaTeX documentation files: TEXDOCDIR := $(DOCDIR)/src/lib # Curry library files LIB_CURRY = $(filter-out $(EXCLUDES), $(wildcard *.curry AbstractCurry/*.curry FlatCurry/*.curry FlatCurry/Annotated/*.curry CLP/*.curry Database/*.curry Database/CDBI/*.curry Rewriting/*.curry Test/*.curry)) # lib names without directory prefix LIB_NAMES = $(subst /,., $(basename $(LIB_CURRY))) # lib names included in library documentation page (without directory prefix) LIB_DOCNAMES = $(filter-out $(DOCEXCLUDES), $(LIB_NAMES)) # Generated files: LIB_FCY = $(foreach lib, $(LIB_CURRY:%.curry=.curry/%.fcy), $(lib)) LIB_ACY = $(foreach lib, $(LIB_CURRY:%.curry=.curry/%.acy), $(lib)) LIB_PL = $(foreach lib, $(LIB_CURRY:%.curry=.curry/pakcs/%.pl), $(lib)) LIB_HTML = $(foreach lib, $(LIB_CURRY:.curry=.html), $(LIBDOCDIR)/$(subst /,.,$(lib))) LIB_TEX = $(foreach lib, $(LIB_CURRY:.curry=.tex), $(TEXDOCDIR)/$(subst /,.,$(lib))) ALLLIBS = AllLibraries # Modules not included as regular libraries: EXCLUDES = $(ALLLIBS).curry UnsafeSearchTree.curry # Modules not included in library documentation index page: DOCEXCLUDES = CHRcompiled CPNS HtmlCgi WUIjs .PHONY: all all: $(ALLLIBS).curry fcy acy # create a program importing all libraries in order to re-compile them # so that all auxiliary files are up-to-date $(ALLLIBS).curry: $(LIB_CURRY) Makefile rm -f $@ for i in $(filter-out Prelude, $(LIB_NAMES)) ; do echo "import $$i" >> $@ ; done .PHONY: allsources allsources: @echo $(LIB_CURRY) # clean all generated files .PHONY: clean clean: rm -f "$(LIBDOCDIR)"/* rm -f "$(TEXDOCDIR)"/* rm -fr .curry # clean all generated Prolog files .PHONY: cleanpl cleanpl: rm -f .curry/pakcs/*.pl .curry/pakcs/*.po ########################################################################## # generate the FlatCurry files of all libraries: .NOTPARALLEL: fcy .PHONY: fcy fcy: $(LIB_FCY) # generate the AbstractCurry files of all libraries: .PHONY: acy acy: $(LIB_ACY) # generate the compiled Prolog target files of all libraries: .NOTPARALLEL: pl .PHONY: pl pl: .curry/pakcs/$(ALLLIBS).pl $(LIB_PL) # generate FlatCurry file in subdirectory .curry: .curry/%.fcy: %.curry "$(CYMAKE)" --flat $(CYMAKEPARAMS) $(subst /,.,$*) # generate all AbstractCurry files in subdirectory .curry: .curry/%.acy: %.curry "$(CYMAKE)" --acy $(CYMAKEPARAMS) $(subst /,.,$*) # generate all Prolog translations: .curry/pakcs/%.pl: .curry/%.fcy rm -f $@ && "$(PAKCS)" --quiet :compile $(subst /,.,$*) :quit ############################################################################## # create HTML documentation files for system libraries ############################################################################## INDEXHTML = $(LIBDOCDIR)/index.html HTMLEXCLUDES = $(INDEXHTML) $(foreach file, findex.html cindex.html PAKCS_libs.html, $(LIBDOCDIR)/$(file)) .PHONY: doc doc: $(LIB_CURRY) @mkdir -p "$(LIBDOCDIR)" @$(MAKE) $(LIB_HTML) @$(MAKE) $(INDEXHTML) $(INDEXHTML): $(filter-out $(HTMLEXCLUDES), $(wildcard $(LIBDOCDIR)/*.html)) @echo "Generating index pages for Curry libraries:" @echo $(LIB_DOCNAMES) "$(PAKCS)" doc --libsindexhtml "$(LIBDOCDIR)" $(LIB_DOCNAMES) # generate individual documentations for libraries $(LIBDOCDIR)/AbstractCurry.%.html: AbstractCurry/%.curry "$(PAKCS)" doc --noindexhtml "$(LIBDOCDIR)" $(subst /,.,$<) $(LIBDOCDIR)/FlatCurry.Annotated.%.html: FlatCurry/Annotated/%.curry "$(PAKCS)" doc --noindexhtml "$(LIBDOCDIR)" $(subst /,.,$<) $(LIBDOCDIR)/FlatCurry.%.html: FlatCurry/%.curry "$(PAKCS)" doc --noindexhtml "$(LIBDOCDIR)" $(subst /,.,$<) $(LIBDOCDIR)/CLP.%.html: CLP/%.curry "$(PAKCS)" doc --noindexhtml "$(LIBDOCDIR)" $(subst /,.,$<) $(LIBDOCDIR)/Database.CDBI.%.html: Database/CDBI/%.curry "$(PAKCS)" doc --noindexhtml "$(LIBDOCDIR)" $(subst /,.,$<) $(LIBDOCDIR)/Database.%.html: Database/%.curry "$(PAKCS)" doc --noindexhtml "$(LIBDOCDIR)" $(subst /,.,$<) $(LIBDOCDIR)/Rewriting.%.html: Rewriting/%.curry "$(PAKCS)" doc --noindexhtml "$(LIBDOCDIR)" $(subst /,.,$<) $(LIBDOCDIR)/Test.%.html: Test/%.curry "$(PAKCS)" doc --noindexhtml "$(LIBDOCDIR)" $(subst /,.,$<) $(LIBDOCDIR)/%.html: %.curry "$(PAKCS)" doc --noindexhtml "$(LIBDOCDIR)" $(subst /,.,$<) ############################################################################## # create LaTeX documentation files for system libraries ############################################################################## .PHONY: texdoc texdoc: $(LIB_CURRY) @mkdir -p "$(TEXDOCDIR)" $(MAKE) $(LIB_TEX) # Generate individual LaTeX documentations for libraries. # In case of failures (which might occur due to memory problems in SWI-Prolog) # an empty LaTeX file is generated so that the make process does not die. $(TEXDOCDIR)/AbstractCurry.%.tex: AbstractCurry/%.curry "$(PAKCS)" doc --tex "$(TEXDOCDIR)" $(subst /,.,$<) || (rm -f $@ && touch $@) $(TEXDOCDIR)/FlatCurry.Annotated.%.tex: FlatCurry/Annotated/%.curry "$(PAKCS)" doc --tex "$(TEXDOCDIR)" $(subst /,.,$<) || (rm -f $@ && touch $@) $(TEXDOCDIR)/FlatCurry.%.tex: FlatCurry/%.curry "$(PAKCS)" doc --tex "$(TEXDOCDIR)" $(subst /,.,$<) || (rm -f $@ && touch $@) $(TEXDOCDIR)/CLP.%.tex: CLP/%.curry "$(PAKCS)" doc --tex "$(TEXDOCDIR)" $(subst /,.,$<) || (rm -f $@ && touch $@) $(TEXDOCDIR)/Database.CDBI.%.tex: Database/CDBI/%.curry "$(PAKCS)" doc --tex "$(TEXDOCDIR)" $(subst /,.,$<) || (rm -f $@ && touch $@) $(TEXDOCDIR)/Database.%.tex: Database/%.curry "$(PAKCS)" doc --tex "$(TEXDOCDIR)" $(subst /,.,$<) || (rm -f $@ && touch $@) $(TEXDOCDIR)/Rewriting.%.tex: Rewriting/%.curry "$(PAKCS)" doc --tex "$(TEXDOCDIR)" $(subst /,.,$<) || (rm -f $@ && touch $@) $(TEXDOCDIR)/Test.%.tex: Test/%.curry "$(PAKCS)" doc --tex "$(TEXDOCDIR)" $(subst /,.,$<) || (rm -f $@ && touch $@) $(TEXDOCDIR)/%.tex: %.curry "$(PAKCS)" doc --tex "$(TEXDOCDIR)" $(subst /,.,$<) || (rm -f $@ && touch $@) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Makefile.pakcs.install000066400000000000000000000072721305333611600254450ustar00rootroot00000000000000# directory containing the repository library files: ifndef CURRYLIBSDIR CURRYLIBSDIR=$(ROOT)/lib-trunk endif # specific PAKCS libraries: PAKCSONLYLIBS = CHR.curry CHRcompiled.curry CLPB.curry CLPFD.curry CLPR.curry CLP/FD.curry \ Database.curry Dynamic.curry Findall.curry \ GlobalVariable.curry KeyDB.curry KeyDatabase.curry \ PlProfileData.curry Ports.curry # get all library files from standard makefile and add PAKCS specific libs: LIB_CURRY = `cd $(CURRYLIBSDIR) && $(MAKE) --no-print-directory --quiet -f Makefile.$(CURRYSYSTEM) allsources` $(PAKCSONLYLIBS) # name of this makefile: CURRENT_MAKEFILE = $(CURRYLIBSDIR)/Makefile.$(CURRYSYSTEM).install ########################################################################## # Install the library sources into the Curry system library directory: .PHONY: install install: mkdir -p $(LIBDIR) mkdir -p $(LIBDIR)/AbstractCurry mkdir -p $(LIBDIR)/FlatCurry/Annotated mkdir -p $(LIBDIR)/CLP mkdir -p $(LIBDIR)/Database/CDBI mkdir -p $(LIBDIR)/Rewriting mkdir -p $(LIBDIR)/Test $(MAKE) -f $(CURRENT_MAKEFILE) $(LIBDIR)/Makefile $(LIBDIR)/test.sh cd $(LIBDIR) && $(MAKE) -f $(CURRENT_MAKEFILE) sources $(LIBDIR)/Makefile: Makefile.$(CURRYSYSTEM) cp $< $@ $(LIBDIR)/test.sh: test.sh cp $< $@ .PHONY: sources sources: @echo LIB_CURRY=$(LIB_CURRY) $(MAKE) -f $(CURRENT_MAKEFILE) $(LIB_CURRY) cp $(CURRYLIBSDIR)/*.prim_c2p . #cp $(CURRYLIBSDIR)/CLP/*.prim_c2p CLP Prelude.curry: $(CURRYLIBSDIR)/Prelude.curry.$(CURRYSYSTEM) cp $< $@ AllSolutions.curry: $(CURRYLIBSDIR)/AllSolutions.curry.$(CURRYSYSTEM) cp $< $@ CLPB.curry: $(CURRYLIBSDIR)/CLPB.curry.$(CURRYSYSTEM) cp $< $@ CHR.curry: $(CURRYLIBSDIR)/CHR.curry.$(CURRYSYSTEM) cp $< $@ CHRcompiled.curry: $(CURRYLIBSDIR)/CHRcompiled.curry.$(CURRYSYSTEM) cp $< $@ CLPFD.curry: $(CURRYLIBSDIR)/CLPFD.curry.$(CURRYSYSTEM) cp $< $@ CLPR.curry: $(CURRYLIBSDIR)/CLPR.curry.$(CURRYSYSTEM) cp $< $@ CLP/FD.curry: $(CURRYLIBSDIR)/CLP/FD.curry.$(CURRYSYSTEM) cp $< $@ Database.curry: $(CURRYLIBSDIR)/Database.curry.$(CURRYSYSTEM) cp $< $@ Dynamic.curry: $(CURRYLIBSDIR)/Dynamic.curry.$(CURRYSYSTEM) cp $< $@ Findall.curry: $(CURRYLIBSDIR)/Findall.curry.$(CURRYSYSTEM) cp $< $@ Global.curry: $(CURRYLIBSDIR)/Global.curry.$(CURRYSYSTEM) cp $< $@ GlobalVariable.curry: $(CURRYLIBSDIR)/GlobalVariable.curry.$(CURRYSYSTEM) cp $< $@ IOExts.curry: $(CURRYLIBSDIR)/IOExts.curry.$(CURRYSYSTEM) cp $< $@ KeyDB.curry: $(CURRYLIBSDIR)/KeyDB.curry.$(CURRYSYSTEM) cp $< $@ KeyDatabase.curry: $(CURRYLIBSDIR)/KeyDatabase.curry.$(CURRYSYSTEM) cp $< $@ PlProfileData.curry: $(CURRYLIBSDIR)/PlProfileData.curry.$(CURRYSYSTEM) cp $< $@ Ports.curry: $(CURRYLIBSDIR)/Ports.curry.$(CURRYSYSTEM) cp $< $@ Profile.curry: $(CURRYLIBSDIR)/Profile.curry.$(CURRYSYSTEM) cp $< $@ Random.curry: $(CURRYLIBSDIR)/Random.curry.$(CURRYSYSTEM) cp $< $@ SearchTree.curry: $(CURRYLIBSDIR)/SearchTree.curry.$(CURRYSYSTEM) cp $< $@ SetFunctions.curry: $(CURRYLIBSDIR)/SetFunctions.curry.$(CURRYSYSTEM) cp $< $@ Unsafe.curry: $(CURRYLIBSDIR)/Unsafe.curry.$(CURRYSYSTEM) cp $< $@ ValueSequence.curry: $(CURRYLIBSDIR)/ValueSequence.curry.$(CURRYSYSTEM) cp $< $@ AbstractCurry/%.curry: $(CURRYLIBSDIR)/AbstractCurry/%.curry cp $< $@ FlatCurry/Annotated/%.curry: $(CURRYLIBSDIR)/FlatCurry/Annotated/%.curry cp $< $@ FlatCurry/%.curry: $(CURRYLIBSDIR)/FlatCurry/%.curry cp $< $@ Database/CDBI/%.curry: $(CURRYLIBSDIR)/Database/CDBI/%.curry cp $< $@ Database/%.curry: $(CURRYLIBSDIR)/Database/%.curry cp $< $@ Rewriting/%.curry: $(CURRYLIBSDIR)/Rewriting/%.curry cp $< $@ Test/%.curry: $(CURRYLIBSDIR)/Test/%.curry cp $< $@ %.curry: $(CURRYLIBSDIR)/%.curry cp $< $@ index.html: $(CURRYLIBSDIR)/index.html.$(CURRYSYSTEM) cp $< $@ curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Markdown.curry000066400000000000000000000474401305333611600241110ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library to translate --- [markdown documents](http://en.wikipedia.org/wiki/Markdown) --- into HTML or LaTeX. --- The slightly restricted subset of the markdown syntax recognized by --- this implementation is --- [documented in this page](http://www.informatik.uni-kiel.de/~pakcs/markdown_syntax.html). --- --- @author Michael Hanus --- @version December 2011 --- @category web ------------------------------------------------------------------------------ module Markdown(MarkdownDoc,MarkdownElem(..),fromMarkdownText, removeEscapes, markdownEscapeChars, markdownText2HTML,markdownText2CompleteHTML, markdownText2LaTeX,markdownText2LaTeXWithFormat, markdownText2CompleteLaTeX, formatMarkdownFileAsPDF,formatMarkdownInputAsPDF) where import List import Char import HTML import HtmlParser import System import IO(getContents) ----------------------------------------------------------------------- --- A markdown document is a list of markdown elements. type MarkdownDoc = [MarkdownElem] --- The data type for representing the different elements --- occurring in a markdown document. --- @cons Text s - a simple text in a markdown document --- @cons Emph s - an emphasized text in a markdown document --- @cons Strong s - a strongly emphaszed text in a markdown document --- @cons Strong s - a code string in a markdown document --- @cons Code s - a code string in a markdown document --- @cons HRef s u - a reference to URL `u` with text `s` in a markdown document --- @cons Par md - a paragraph in a markdown document --- @cons CodeBlock s - a code block in a markdown document --- @cons UList mds - an unordered list in a markdown document --- @cons OList mds - an ordered list in a markdown document --- @cons Quote md - a quoted paragraph in a markdown document --- @cons HRule - a hoirzontal rule in a markdown document --- @cons Header l s - a level `l` header with title `s` --- in a markdown document data MarkdownElem = Text String | Emph String | Strong String | Code String | HRef String String | Par MarkdownDoc | CodeBlock String | UList [MarkdownDoc] | OList [MarkdownDoc] | Quote MarkdownDoc | HRule | Header Int String ----------------------------------------------------------------------- --- The data type for representing the different elements --- of a source markdown document. Basically, it is the same --- as the final markdown document execept for single list items --- that occur in the source but are combined into a list in --- the final document. data SourceMDElem = SMDText String | SMDEmph String | SMDStrong String | SMDCode String | SMDHRef String String | SMDPar MarkdownDoc | SMDCodeBlock String | SMDUItem String | SMDOItem String | SMDQuote MarkdownDoc | SMDHRule | SMDHeader Int String isSMDUItem :: SourceMDElem -> Bool isSMDUItem md = case md of SMDUItem _ -> True _ -> False isSMDOItem :: SourceMDElem -> Bool isSMDOItem md = case md of SMDOItem _ -> True _ -> False textOfItem :: SourceMDElem -> String textOfItem (SMDUItem txt) = txt textOfItem (SMDOItem txt) = txt ----------------------------------------------------------------------- --- Parse markdown document from its textual representation. fromMarkdownText :: String -> MarkdownDoc fromMarkdownText = groupMarkDownElems . markdownText -- Group adjacent item elements together in a markdown list. groupMarkDownElems :: [SourceMDElem] -> MarkdownDoc groupMarkDownElems [] = [] groupMarkDownElems (SMDUItem itxt :mds) = joinItems UList isSMDUItem [itxt] mds groupMarkDownElems (SMDOItem itxt :mds) = joinItems OList isSMDOItem [itxt] mds groupMarkDownElems (SMDText s : mds) = Text s : groupMarkDownElems mds groupMarkDownElems (SMDEmph s : mds) = Emph s : groupMarkDownElems mds groupMarkDownElems (SMDStrong s : mds) = Strong s : groupMarkDownElems mds groupMarkDownElems (SMDCode s : mds) = Code s : groupMarkDownElems mds groupMarkDownElems (SMDHRef s u : mds) = HRef s u : groupMarkDownElems mds groupMarkDownElems (SMDPar md : mds) = Par md : groupMarkDownElems mds groupMarkDownElems (SMDCodeBlock s : mds) = CodeBlock s : groupMarkDownElems mds groupMarkDownElems (SMDQuote md : mds) = Quote md : groupMarkDownElems mds groupMarkDownElems (SMDHRule : mds) = HRule : groupMarkDownElems mds groupMarkDownElems (SMDHeader l s : mds) = Header l s : groupMarkDownElems mds joinItems :: ([[MarkdownElem]] -> MarkdownElem) -> (SourceMDElem -> Bool) -> [String] -> [SourceMDElem] -> [MarkdownElem] joinItems mdlcons _ items [] = [mdlcons (reverse (map fromMarkdownText items))] joinItems mdlcons isitem items (md:mds) = if isitem md then joinItems mdlcons isitem (textOfItem md : items) mds else mdlcons (reverse (map fromMarkdownText items)) : groupMarkDownElems (md:mds) -- Basic reader for a markdown text. markdownText :: String -> [SourceMDElem] markdownText [] = [] markdownText txt@(_:_) = markdownLine fstline (dropFirst remtxt) where (fstline,remtxt) = break (=='\n') txt -- Analyze the first line of a markdown text: markdownLine :: String -> String -> [SourceMDElem] markdownLine fstline remtxt | all isSpace fstline = markdownText remtxt | isLevel1Line = SMDHeader 1 fstline : markdownText (dropFirst furtherlines) | isLevel2Line = SMDHeader 2 fstline : markdownText (dropFirst furtherlines) | take 1 fstline == "#" = tryMDHeader fstline remtxt | isHRule fstline = SMDHRule : markdownText remtxt | take 2 fstline == "> " -- start of a quoted text = markdownQuote (drop 2 fstline) remtxt | blanklen > 0 -- four space indent for code = markdownCodeBlock blanklen (removeEscapes (drop blanklen fstline)) remtxt | uitemlen > 0 -- start of an unordered item = markdownItem SMDUItem uitemlen (drop uitemlen fstline) remtxt | nitemlen > 0 -- start of a numbered item = markdownItem SMDOItem nitemlen (drop nitemlen fstline) remtxt | otherwise = markdownPar fstline remtxt where (sndline,furtherlines) = break (=='\n') remtxt isLevel1Line = not (null sndline) && all (=='=') sndline isLevel2Line = not (null sndline) && all (=='-') sndline nitemlen = isNumberedItemLine fstline uitemlen = isUnorderedItemLine fstline blanklen = isCodeLine fstline dropFirst :: [a] -> [a] dropFirst s = if null s then [] else tail s -- translate a header line tryMDHeader :: String -> String -> [SourceMDElem] tryMDHeader s rtxt = let (sharps,htxt) = break (==' ') s level = length sharps in if null htxt || level>6 then markdownPar s rtxt else SMDHeader level (dropFirst htxt) : markdownText rtxt -- is a line a horizontal rule: isHRule :: String -> Bool isHRule l = (all (\c -> isSpace c || c=='-') l && length (filter (=='-') l) > 3) || (all (\c -> isSpace c || c=='*') l && length (filter (=='*') l) > 3) -- check whether a line starts with an unordered item indicator ("* ") -- and return indent: isUnorderedItemLine :: String -> Int isUnorderedItemLine s = let (blanks,nonblanks) = span (==' ') s in if take 2 nonblanks `elem` ["* ","- ","+ "] then length blanks+2 else 0 -- check whether a line starts with an indented number and return indent value: isNumberedItemLine :: String -> Int isNumberedItemLine s = let (blanks,nonblanks) = span (==' ') s numblanks = length blanks in checkNumber numblanks nonblanks where checkNumber indt numtxt = let (ns,brt) = break (==' ') numtxt (blanks,rtxt) = break (/=' ') brt nsl = length ns in if nsl>0 && all isDigit (take (nsl-1) ns) && ns!!(nsl-1)=='.' && not (null blanks) && not (null rtxt) then indt+nsl+length blanks else 0 -- check whether a line starts with at least four blanks and return indent value: isCodeLine :: String -> Int isCodeLine s = let (blanks,nonblanks) = span (==' ') s numblanks = length blanks in if not (null nonblanks) && numblanks >= 4 then numblanks else 0 -- parse a paragraph (where the initial part of the paragraph is given -- as the first argument): markdownPar :: String -> String -> [SourceMDElem] markdownPar ptxt txt | null txt || head txt `elem` ['\n'] || uitemlen>0 || nitemlen>0 = SMDPar (groupMarkDownElems (outsideMarkdownElem "" ptxt)) : markdownText txt | null remtxt = [SMDPar (groupMarkDownElems (outsideMarkdownElem "" (ptxt++'\n':fstline)))] | otherwise = markdownPar (ptxt++'\n':fstline) (tail remtxt) where (fstline,remtxt) = break (=='\n') txt nitemlen = isNumberedItemLine fstline uitemlen = isUnorderedItemLine fstline -- parse a quoted section: markdownQuote :: String -> String -> [SourceMDElem] markdownQuote qtxt alltxt = let txt = if take 2 alltxt == ">\n" -- allow empty quote lines then "> " ++ drop 1 alltxt else alltxt in if take 2 txt == "> " then let (fstline,remtxt) = break (=='\n') (drop 2 txt) in if null remtxt then [SMDQuote (fromMarkdownText (qtxt++'\n':fstline))] else markdownQuote (qtxt++'\n':fstline) (tail remtxt) else SMDQuote (fromMarkdownText qtxt) : markdownText txt -- parse a program block (where the indent and the initial code block is given): markdownCodeBlock :: Int -> String -> String -> [SourceMDElem] markdownCodeBlock n ctxt txt = if take n txt == " " then let (fstline,remtxt) = break (=='\n') (drop n txt) in if null remtxt then [SMDCodeBlock (ctxt++'\n':removeEscapes fstline)] else markdownCodeBlock n (ctxt++'\n':removeEscapes fstline) (tail remtxt) else SMDCodeBlock ctxt : markdownText txt -- parse a markdown list item: markdownItem :: (String -> SourceMDElem) -> Int -> String -> String -> [SourceMDElem] markdownItem icons n itxt txt = if take n txt == take n (repeat ' ') then let (fstline,remtxt) = break (=='\n') (drop n txt) in if null remtxt then [icons (itxt++'\n':fstline)] else markdownItem icons n (itxt++'\n':fstline) (tail remtxt) else let (fstline,remtxt) = break (=='\n') txt in if all isSpace fstline then if null remtxt then [icons itxt] else markdownItem icons n (itxt++"\n") (tail remtxt) else icons itxt : markdownText txt --- Remove the backlash of escaped markdown characters in a string. removeEscapes :: String -> String removeEscapes s = case s of [] -> [] ('\\':c:cs) -> if c `elem` markdownEscapeChars then c : removeEscapes cs else '\\' : removeEscapes (c:cs) (c:cs) -> c : removeEscapes cs --- Escape characters supported by markdown. markdownEscapeChars :: [Char] markdownEscapeChars = ['\\','`','*','_','{','}','[',']','(',')','#','+','-','.',' ','!'] -- Analyze markdown text outside an element like emphasis, code, strong: outsideMarkdownElem :: String -> String -> [SourceMDElem] outsideMarkdownElem txt s = case s of [] -> addPrevious txt [] ('\\':c:cs) -> if c `elem` markdownEscapeChars then outsideMarkdownElem (c:'\\':txt) cs else outsideMarkdownElem ('\\':txt) (c:cs) ('*':'*':cs) -> addPrevious txt $ insideMarkdownElem "**" [] cs ('_':'_':cs) -> addPrevious txt $ insideMarkdownElem "__" [] cs ('*':cs) -> addPrevious txt $ insideMarkdownElem "*" [] cs ('_':cs) -> addPrevious txt $ insideMarkdownElem "_" [] cs ('`':cs) -> addPrevious txt $ insideMarkdownElem "`" [] cs ('[':cs) -> addPrevious txt $ tryParseLink cs ('<':cs) -> if take 4 cs == "http" then addPrevious txt $ markdownHRef cs else outsideMarkdownElem ('<':txt) cs (c:cs) -> outsideMarkdownElem (c:txt) cs addPrevious :: String -> [SourceMDElem] -> [SourceMDElem] addPrevious ptxt xs = if null ptxt then xs else SMDText (reverse ptxt) : xs -- Try to parse a link of the form [link test](url) tryParseLink :: String -> [SourceMDElem] tryParseLink txt = let (linktxt,rtxt) = break (==']') txt in if null rtxt || null (tail rtxt) || (rtxt!!1 /= '(') then outsideMarkdownElem "[" txt else let (url,mtxt) = break (==')') (drop 2 rtxt) in if null mtxt then outsideMarkdownElem "[" txt else SMDHRef linktxt url : outsideMarkdownElem "" (tail mtxt) markdownHRef :: String -> [SourceMDElem] markdownHRef txt = let (url,rtxt) = break (=='>') txt in if null rtxt then outsideMarkdownElem "" ('<':txt) else SMDHRef url url : outsideMarkdownElem "" (dropFirst rtxt) insideMarkdownElem :: String -> String -> String -> [SourceMDElem] insideMarkdownElem marker etext s = if marker `isPrefixOf` s then text2MDElem marker (reverse etext) : outsideMarkdownElem "" (drop (length marker) s) else case s of [] -> [SMDText (marker ++ reverse etext)] -- end marker missing ('\\':c:cs) -> if c `elem` markdownEscapeChars then insideMarkdownElem marker (c:'\\':etext) cs else insideMarkdownElem marker ('\\':etext) (c:cs) (c:cs) -> insideMarkdownElem marker (c:etext) cs text2MDElem :: String -> String -> SourceMDElem text2MDElem marker txt = case marker of "**" -> SMDStrong txt "__" -> SMDStrong txt "*" -> SMDEmph txt "_" -> SMDEmph txt "`" -> SMDCode txt _ -> error $ "Markdown.text2MDElem: unknown marker \""++marker++"\"" ----------------------------------------------------------------------- -- Translate markdown document to HTML. mdDoc2html :: MarkdownDoc -> [HtmlExp] mdDoc2html = map mdElem2html -- translate markdown special characters in text to HTML mdtxt2html :: String -> HtmlExp mdtxt2html s = HtmlText (removeEscapes s) mdElem2html :: MarkdownElem -> HtmlExp mdElem2html (Text s) = mdtxt2html s mdElem2html (Emph s) = emphasize [mdtxt2html s] mdElem2html (Strong s) = HtmlStruct "strong" [] [mdtxt2html s] mdElem2html (HRef s url) = if s==url then href url [code [mdtxt2html s]] else href url [mdtxt2html s] mdElem2html (Code s) = code [HtmlText (htmlQuote s)] mdElem2html (CodeBlock s) = verbatim s mdElem2html (Quote md) = HtmlStruct "blockquote" [] (mdDoc2html md) mdElem2html (Par md) = par (mdDoc2html md) mdElem2html (UList mds) = ulist (map mdDoc2htmlWithoutPar mds) mdElem2html (OList mds) = olist (map mdDoc2htmlWithoutPar mds) mdElem2html HRule = hrule mdElem2html (Header l s) = HtmlStruct ('h':show l) [] [mdtxt2html s] mdDoc2htmlWithoutPar :: MarkdownDoc -> [HtmlExp] mdDoc2htmlWithoutPar mdoc = case mdoc of [] -> [] [Par md] -> mdDoc2html md [md] -> [mdElem2html md] (Par md1:md2:mds) -> mdDoc2html md1 ++ breakline : mdDoc2htmlWithoutPar (md2:mds) (md1:md2:mds) -> mdElem2html md1 : mdDoc2htmlWithoutPar (md2:mds) --- Translate a markdown text into a (partial) HTML document. markdownText2HTML :: String -> [HtmlExp] markdownText2HTML = mdDoc2html . fromMarkdownText --- Translate a markdown text into a complete HTML text --- that can be viewed as a standalone document by a browser. --- The first argument is the title of the document. markdownText2CompleteHTML :: String -> String -> String markdownText2CompleteHTML title mdtxt = showHtmlPage (page title (markdownText2HTML mdtxt)) ----------------------------------------------------------------------- --- Translate markdown document to a LaTeX string where the first --- argument is a function to translate the basic text occurring --- in markdown elements to a LaTeX string. --- Note that the basic text (execept for code blocks) --- contains escaped markdown characters --- that needs also to be removed by the translation function. mdDoc2latex :: (String->String) -> MarkdownDoc -> String mdDoc2latex txt2latex = concatMap (mdElem2latex txt2latex) mdElem2latex :: (String->String) -> MarkdownElem -> String mdElem2latex txt2latex (Text s) = txt2latex s mdElem2latex txt2latex (Emph s) = "\\emph{"++txt2latex s++"}" mdElem2latex txt2latex (Strong s) = "\\textbf{"++txt2latex s++"}" mdElem2latex txt2latex (HRef s url) = if s==url then "\\url{"++url++"}" else "\\href{"++url++"}{"++txt2latex s++"}" mdElem2latex txt2latex (Code s) = "\\texttt{"++txt2latex (htmlQuote s)++"}" mdElem2latex _ (CodeBlock s) = "\\begin{verbatim}\n"++s++"\n\\end{verbatim}\n" mdElem2latex txt2latex (Quote md) = "\\begin{quote}\n"++mdDoc2latex txt2latex md++"\\end{quote}\n" mdElem2latex txt2latex (Par md) = mdDoc2latex txt2latex md++"\n\n" mdElem2latex txt2latex (UList s) = "\\begin{itemize}"++ concatMap (\i -> "\n\\item\n"++mdDoc2latex txt2latex i) s ++ "\\end{itemize}\n" mdElem2latex txt2latex (OList s) = "\\begin{enumerate}"++ concatMap (\i -> "\n\\item\n"++mdDoc2latex txt2latex i) s ++ "\\end{enumerate}\n" mdElem2latex _ HRule = "\\begin{center}\\rule{3in}{0.4pt}\\end{center}\n\n" mdElem2latex txt2latex (Header l s) = case l of 1 -> "\\section{"++txt2latex s++"}\n\n" 2 -> "\\subsection{"++txt2latex s++"}\n\n" 3 -> "\\subsubsection{"++txt2latex s++"}\n\n" 4 -> "\\paragraph{"++txt2latex s++"}\n\n" 5 -> "\\textbf{"++txt2latex s++"}\n\n" _ -> "\\emph{"++txt2latex s++"}\n\n" --- Translator for basic text to LaTeX. --- markdown escapes are removed and possible HTML markups --- are translated to LaTeX. html2latex :: String -> String html2latex = showLatexExps . parseHtmlString . removeEscapes --- Translate a markdown text into a (partial) LaTeX document. --- All characters with a special meaning in LaTeX, like dollar --- or ampersand signs, are quoted. markdownText2LaTeX :: String -> String markdownText2LaTeX = mdDoc2latex html2latex . fromMarkdownText --- Translate a markdown text into a (partial) LaTeX document --- where the first argument is a function to translate the basic text --- occurring in markdown elements to a LaTeX string. --- For instance, one can use a translation operation --- that supports passing mathematical formulas in LaTeX style --- instead of quoting all special characters. markdownText2LaTeXWithFormat :: (String->String) -> String -> String markdownText2LaTeXWithFormat txt2latex = mdDoc2latex txt2latex . fromMarkdownText --- Translate a markdown text into a complete LaTeX document --- that can be formatted as a standalone document. markdownText2CompleteLaTeX :: String -> String markdownText2CompleteLaTeX mds = latexHeader ++ mdDoc2latex html2latex (fromMarkdownText mds) ++ "\\end{document}\n" latexHeader :: String latexHeader = "\\documentclass{article}\n"++ "\\usepackage[utf8x]{inputenc}\n"++ "\\usepackage{url}\n"++ "\\usepackage[breaklinks=true,unicode=true]{hyperref}\n"++ "\\setlength{\\parindent}{0pt}\n"++ "\\setlength{\\parskip}{6pt plus 2pt minus 1pt}\n"++ "\\setcounter{secnumdepth}{0}\n"++ "\\begin{document}\n" --- Format the standard input (containing markdown text) as PDF. formatMarkdownInputAsPDF :: IO () formatMarkdownInputAsPDF = getContents >>= formatMarkdownAsPDF --- Format a file containing markdown text as PDF. formatMarkdownFileAsPDF :: String -> IO () formatMarkdownFileAsPDF fname = readFile fname >>= formatMarkdownAsPDF --- Format a file containing markdown text as PDF. formatMarkdownAsPDF :: String -> IO () formatMarkdownAsPDF mdstr = do pid <- getPID let tmp = "tmp_"++show pid writeFile (tmp++".tex") (markdownText2CompleteLaTeX mdstr) pdflatexFile tmp -- Format a file tmp.tex with pdflatex and show the result pdflatexFile :: String -> IO () pdflatexFile tmp = do system $ "pdflatex \'\\nonstopmode\\input{"++tmp++".tex}\'" system $ "/bin/rm -f "++tmp++".tex "++tmp++".aux "++tmp++".log "++tmp++".out" system $ "evince "++tmp++".pdf" system $ "/bin/rm -f "++tmp++".pdf" done ----------------------------------------------------------------------- curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Maybe.curry000066400000000000000000000052241305333611600233560ustar00rootroot00000000000000--- ---------------------------------------------------------------------------- --- Library with some useful functions on the `Maybe` datatype. --- --- @author Frank Huch, Bernd Brassel, Bjoern Peemoeller --- @version October 2014 --- @category general --- ---------------------------------------------------------------------------- module Maybe ( Maybe (..) , maybe , isJust, isNothing , fromJust, fromMaybe , listToMaybe, maybeToList , catMaybes, mapMaybe , (>>-), sequenceMaybe, mapMMaybe, mplus ) where infixl 1 >>- --- Return `True` iff the argument is of the form `Just _`. isJust :: Maybe _ -> Bool isJust (Just _) = True isJust Nothing = False --- Return `True` iff the argument is of the form `Nothing`. isNothing :: Maybe _ -> Bool isNothing Nothing = True isNothing (Just _) = False --- Extract the argument from the `Just` constructor and throw an error --- if the argument is `Nothing`. fromJust :: Maybe a -> a fromJust (Just a) = a fromJust Nothing = error "Maybe.fromJust: Nothing" --- Extract the argument from the `Just` constructor or return the provided --- default value if the argument is `Nothing`. fromMaybe :: a -> Maybe a -> a fromMaybe d Nothing = d fromMaybe _ (Just a) = a --- Return `Nothing` on an empty list or `Just x` where `x` is the first --- list element. listToMaybe :: [a] -> Maybe a listToMaybe [] = Nothing listToMaybe (a : _) = Just a --- Return an empty list for `Nothing` or a singleton list for `Just x`. maybeToList :: Maybe a -> [a] maybeToList Nothing = [] maybeToList (Just a) = [a] --- Return the list of all `Just` values. catMaybes :: [Maybe a] -> [a] catMaybes ms = [ m | (Just m) <- ms ] --- Apply a function which may throw out elements using the `Nothing` --- constructor to a list of elements. mapMaybe :: (a -> Maybe b) -> [a] -> [b] mapMaybe f = catMaybes . map f --- Monadic bind for Maybe. --- Maybe can be interpreted as a monad where Nothing is interpreted --- as the error case by this monadic binding. --- @param maybeValue - Nothing or Just x --- @param f - function to be applied to x --- @return Nothing if maybeValue is Nothing, otherwise f is applied to x (>>-) :: Maybe a -> (a -> Maybe b) -> Maybe b Nothing >>- _ = Nothing Just x >>- f = f x --- Monadic `sequence` for `Maybe`. sequenceMaybe :: [Maybe a] -> Maybe [a] sequenceMaybe [] = Just [] sequenceMaybe (c:cs) = c >>- \x -> sequenceMaybe cs >>- \xs -> Just (x:xs) --- Monadic `map` for `Maybe`. mapMMaybe :: (a -> Maybe b) -> [a] -> Maybe [b] mapMMaybe f = sequenceMaybe . map f --- Combine two `Maybe`s, returning the first `Just` value, if any. mplus :: Maybe a -> Maybe a -> Maybe a Nothing `mplus` y = y x@(Just _) `mplus` _ = x curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/NamedSocket.curry000066400000000000000000000137731305333611600245260ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library to support network programming with sockets that are addressed --- by symbolic names. In contrast to raw sockets (see library --- Socket), this library uses the Curry Port Name Server --- to provide sockets that are addressed by symbolic names --- rather than numbers. --- --- In standard applications, the server side uses the operations --- listenOn and socketAccept to provide some service --- on a named socket, and the client side uses the operation --- connectToSocket to request a service. --- --- @author Michael Hanus --- @version February 2008 --- @category general ------------------------------------------------------------------------------ module NamedSocket(Socket, listenOn, socketAccept, waitForSocketAccept, connectToSocketRepeat, connectToSocketWait, sClose, socketName, connectToSocket) where import System import IO(Handle) import qualified Socket import CPNS --------------------------------------------------------------------- -- Server side operations: --- Abstract type for named sockets. data Socket = NamedSocket String Socket.Socket --- Creates a server side socket with a symbolic name. listenOn :: String -> IO Socket listenOn socketname = do (port,socket) <- Socket.listenOnFresh registerPort socketname port 0 return (NamedSocket socketname socket) --- Returns a connection of a client to a socket. --- The connection is returned as a pair consisting of a string identifying --- the client (the format of this string is implementation-dependent) --- and a handle to a stream communication with the client. --- The handle is both readable and writable. socketAccept :: Socket -> IO (String,Handle) socketAccept (NamedSocket _ socket) = Socket.socketAccept socket --- Waits until a connection of a client to a socket is available. --- If no connection is available within the time limit, it returns Nothing, --- otherwise the connection is returned as a pair consisting --- of a string identifying the client --- (the format of this string is implementation-dependent) --- and a handle to a stream communication with the client. --- @param socket - a socket --- @param timeout - milliseconds to wait for input (< 0 : no time out) waitForSocketAccept :: Socket -> Int -> IO (Maybe (String,Handle)) waitForSocketAccept (NamedSocket _ socket) = Socket.waitForSocketAccept socket --- Closes a server socket. sClose :: Socket -> IO () sClose (NamedSocket socketname socket) = do Socket.sClose socket unregisterPort socketname --- Returns a the symbolic name of a named socket. socketName :: Socket -> String socketName (NamedSocket socketname _) = socketname --------------------------------------------------------------------- -- Client side operations: --- Waits for connection to a Unix socket with a symbolic name. --- In contrast to connectToSocket, this action waits until --- the socket has been registered with its symbolic name. --- @param waittime - the time to wait before retrying (in milliseconds) --- @param action - I/O action to be executed before each wait cycle --- @param retries - number of retries before giving up (-1 = retry forever) --- @param nameAtHost - the symbolic name of the socket --- (must be either of the form "name@host" or "name" --- where the latter is a shorthand for "name@localhost") --- @return Nothing (if connection is not possible within the given limits) --- or (Just h) where h is the handle of the connection connectToSocketRepeat :: Int -> IO _ -> Int -> String -> IO (Maybe Handle) connectToSocketRepeat waittime action retries nameAtHost = do let (name,atHost) = break (=='@') nameAtHost host = if atHost=="" then "localhost" else tail atHost -- check whether remote CPNS demon is alive: alive <- cpnsAlive waittime host if not alive then tryAgain else do -- get remote socket/port numbers: (snr,_) <- getPortInfo name host if snr==0 then tryAgain else Socket.connectToSocket host snr >>= return . Just where tryAgain = if retries==0 then return Nothing else do action sleep (ms2s waittime) connectToSocketRepeat waittime action (decr retries) nameAtHost ms2s n = let mn = n `div` 1000 in if mn==0 then 1 else mn decr n = if n<0 then n else n-1 --- Waits for connection to a Unix socket with a symbolic name and --- return the handle of the connection. --- This action waits (possibly forever) until the socket with the symbolic --- name is registered. --- @param nameAtHost - the symbolic name of the socket --- (must be either of the form "name@host" or "name" --- where the latter is a shorthand for "name@localhost") --- @return the handle of the connection (connected to the socket nameAtHost) --- which is both readable and writable connectToSocketWait :: String -> IO Handle connectToSocketWait nameAtHost = do Just hdl <- connectToSocketRepeat 1000 done (-1) nameAtHost return hdl --- Creates a new connection to an existing(!) Unix socket with a symbolic --- name. If the symbolic name is not registered, an error is reported. --- @param nameAtHost - the symbolic name of the socket --- (must be either of the form "name@host" or "name" --- where the latter is a shorthand for "name@localhost") --- @return the handle of the stream (connected to the socket nameAtHost) --- which is both readable and writable connectToSocket :: String -> IO Handle connectToSocket nameAtHost = do let (name,atHost) = break (=='@') nameAtHost host = if atHost=="" then "localhost" else tail atHost -- get remote port number: (snr,_) <- getPortInfo name host if snr==0 then error ("connectToSocket: Socket \""++name++"@"++host++ "\" is not registered!") else done Socket.connectToSocket host snr --------------------------------------------------------------------- curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Nat.curry000066400000000000000000000023611305333611600230420ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library defining natural numbers in Peano representation and --- some operations on this representation. --- --- @author Michael Hanus --- @version May 2016 --- @category general ------------------------------------------------------------------------------ module Nat ( Nat(..), fromNat, toNat, add, sub, mul, leq ) where --- Natural numbers defined in Peano representation. data Nat = Z | S Nat --- Transforms a natural number into a standard integer. fromNat :: Nat -> Int fromNat Z = 0 fromNat (S n) = 1 + fromNat n --- Transforms a standard integer into a natural number. toNat :: Int -> Nat toNat n | n == 0 = Z | n > 0 = S (toNat (n-1)) toNat'pre :: Int -> Bool toNat'pre n = n >= 0 --- Addition on natural numbers. add :: Nat -> Nat -> Nat add Z n = n add (S m) n = S(add m n) --- Subtraction defined by reversing addition. sub :: Nat -> Nat -> Nat sub x y | add y z == x = z where z free --- Multiplication on natural numbers. mul :: Nat -> Nat -> Nat mul Z _ = Z mul (S m) n = add n (mul m n) -- less-or-equal predicated on natural numbers: leq :: Nat -> Nat -> Bool leq Z _ = True leq (S _) Z = False leq (S x) (S y) = leq x y curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Parser.curry000066400000000000000000000100441305333611600235510ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library with functional logic parser combinators. --- --- Adapted from: Rafael Caballero and Francisco J. Lopez-Fraguas: --- A Functional Logic Perspective of Parsing. --- In Proc. FLOPS'99, Springer LNCS 1722, pp. 85-99, 1999 --- --- @author Michael Hanus --- @version December 2012 --- @category general ------------------------------------------------------------------------------ module Parser where -- Operator declarations for the parser combinators: infixr 4 <*> infixr 3 >>> infixr 2 <|>, <||> -- We distinguish two kind of parsers: -- A parser without a representation has type "[token] -> [token]": -- it parses a list of tokens and returns the remaining unparsed tokens type Parser token = [token] -> [token] -- A parser with representation has type "rep -> [token] -> [token]": -- in addition to the input tokens, it has the representation as an argument -- (which is usually a free variable bound to the representation after parsing) type ParserRep rep token = rep -> Parser token -- Now we can define the basic combinators for parsers: --- Combines two parsers without representation in an alternative manner. (<|>) :: Parser t -> Parser t -> Parser t p <|> q = \sentence -> p sentence ? q sentence --- Combines two parsers with representation in an alternative manner. (<||>) :: ParserRep r t -> ParserRep r t -> ParserRep r t p <||> q = \rep -> p rep <|> q rep --- Combines two parsers (with or without representation) in a --- sequential manner. (<*>) :: Parser t -> Parser t -> Parser t p1 <*> p2 = seq where seq sentence | p1 sentence =:= sent1 = p2 sent1 where sent1 free --- Attaches a representation to a parser without representation. (>>>) :: Parser token -> rep -> ParserRep rep token parser >>> repexp = attach where attach rep sentence | parser sentence =:= rest &> repexp =:= rep = rest where rest free -- Finally, we define some useful basic parsers and derived combinators: --- The empty parser which recognizes the empty word. empty :: Parser _ empty sentence = sentence --- A parser recognizing a particular terminal symbol. terminal :: token -> Parser token terminal sym (token:tokens) | sym=:=token = tokens --- A parser (with representation) recognizing a terminal satisfying --- a given predicate. satisfy :: (token->Bool) -> ParserRep token token satisfy pred sym (token:tokens) | pred token =:= True & sym=:=token = tokens --- A star combinator for parsers. The returned parser --- repeats zero or more times a parser p with representation and --- returns the representation of all parsers in a list. star :: ParserRep rep token -> ParserRep [rep] token star p = p x <*> (star p) xs >>> (x:xs) <||> empty >>> [] where x,xs free --- A some combinator for parsers. The returned parser --- repeats the argument parser (with representation) at least once. some :: ParserRep rep token -> ParserRep [rep] token some p = p x <*> (star p) xs >>> (x:xs) where x,xs free {----------------------------------------------------------------------- As a simple example we define a parser for arithmetic expressions over natural numbers. The presentation of this parser is the value of the expression. expression = term t <*> plus_minus op <*> expression e >>> (op t e) <||> term where op,t,e free term = factor f <*> prod_div op <*> term t >>> (op f t) <||> factor where op,f,t free factor = terminal '(' <*> expression e <*> terminal ')' >>> e <||> num where e free plus_minus = terminal '+' >>> (+) <||> terminal '-' >>> (-) prod_div = terminal '*' >>> (*) <||> terminal '/' >>> div num = some digit l >>> numeric_value l where l free numeric_value ds = foldl1 ((+).(10*)) (map (\c->ord c - ord '0') ds) digit = satisfy isDigit -- example application: expression val "(10+5*2)/4" =:= [] -----------------------------------------------------------------------} curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/PlProfileData.curry.pakcs000066400000000000000000000030741305333611600261100ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library to access profile data of the Prolog system --- --- IMPORT NOTE: If this module is used, one must set the PAKCS option --- "plprofile" (wiht ":set +plprofile") in order to make the profile --- data available from the Prolog system! --- --- @author Michael Hanus --- @version February 2004 --- @category general ------------------------------------------------------------------------------ module PlProfileData where -- Kind of selected profile data: data ProfileSelection = Calls | Backtracks | ChoicePoints | ExecTime --- Resets all profile counters. profileReset :: IO () profileReset external --- Gets profile data of all predicates. profilePredicates :: ProfileSelection -> IO [(String,Int)] profilePredicates ps = prim_profilePredicates $# ps prim_profilePredicates :: ProfileSelection -> IO [(String,Int)] prim_profilePredicates external --- Gets profile data of all clauses of a particular predicate. --- The result is a list of pairs (predicate number, profile count) profileClauses :: ProfileSelection -> String -> IO [(Int,Int)] profileClauses ps pred = (prim_profileClauses $# ps) $## pred prim_profileClauses :: ProfileSelection -> String -> IO [(Int,Int)] prim_profileClauses external --- Starts graphical viewer for profile data via the Gauge profiling --- tool of Sicstus Prolog. profileView :: IO () profileView external --- Gets the association of HNF clauses to functions symbols --- (only for internal use). getHnfDefinitions :: IO [(Int,String)] getHnfDefinitions external curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/PlProfileData.prim_c2p000066400000000000000000000015141305333611600253540ustar00rootroot00000000000000 prim_plprofiledata prim_profileReset prim_plprofiledata prim_profilePredicates prim_plprofiledata prim_profileClauses prim_plprofiledata prim_profileView prim_plprofiledata prim_getHnfDefinitions curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Ports.curry.pakcs000066400000000000000000000266321305333611600245360ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for distributed programming with ports. --- --- This paper contains a description of the basic ideas --- behind this library. --- --- @author Michael Hanus --- @version April 2007 --- @category general ------------------------------------------------------------------------------ module Ports(Port,openPort,send,doSend,openNamedPort, connectPort,connectPortRepeat,connectPortWait, ping,timeoutOnStream, openProcessPort,SP_Msg(..),choiceSPEP, newObject,newNamedObject,runNamedServer ) where import Time import System(system,sleep,getPID) import CPNS --- The internal constructor for the port datatype is not visible to the user. data Port a = internalPort String Int Int a --- Opens an internal port for communication. --- @param p - a free variable which will be constrained --- with the port messages --- @param s - a free variable which will be instantiated --- to the stream of incoming messages openPort :: Port a -> [a] -> Bool openPort p ms = (prim_openPort $! p) $!! ms prim_openPort :: Port a -> [a] -> Bool prim_openPort external --- Sends a message to a port. send :: a -> Port a -> Bool send msg p = (prim_send $!! ensureNotFree msg) $# p prim_send :: a -> Port a -> Bool prim_send external --- I/O action that sends a message to a port. doSend :: a -> Port a -> IO () doSend msg p = doSolve (send msg p) --- A constrained which is satisfied after some amount of time --- (currently only supported in TasteCurry). --- @param n - the satisfaction time in milliseconds after :: Int -> Bool after external --- Checks whether port p is still reachable. --- @param n - the time to wait for reachability in milliseconds --- @param p - a port to be checked for reachability --- @return Nothing if port p is unreachable within n milliseconds, --- or (Just m) if port p could be contacted within m milliseconds ping :: Int -> Port _ -> IO (Maybe Int) ping n p = (prim_ping $# n) $# p prim_ping :: Int -> Port _ -> IO (Maybe Int) prim_ping external --- Checks for instantiation of a stream within some amount of time. --- @param n - the time to wait for instantiation in milliseconds --- @param str - the stream to be checked for instantiation --- (usually the stream of incoming messages at some port) --- @return (Just str) if str is instantiated within n milliseconds, --- or Nothing otherwise timeoutOnStream :: Int -> [a] -> Maybe [a] timeoutOnStream n str = (prim_timeoutOnStream $# n) str prim_timeoutOnStream :: Int -> [a] -> Maybe [a] prim_timeoutOnStream external --- A "stream port" is an adaption of the port concept to model the --- communication with bidirectional streams, i.e., a stream port is --- a port connection to a bidirectional stream (e.g., opened by --- openProcessPort) where the communication --- is performed via the following stream port messages. --- --- @cons SP_Put s - write the argument s on the output stream --- @cons SP_GetLine s - unify the argument s with the next text line of the --- input stream --- @cons SP_GetChar c - unify the argument c with the next character of the --- input stream --- @cons SP_EOF b - unify the argument b with True if we are at the end --- of the input stream, otherwise with False --- @cons SP_Close - close the input/output streams data SP_Msg = SP_Put String -- write the argument on the output stream | SP_GetLine String -- unify the argument with the next text line of the -- input stream | SP_GetChar Char -- unify the argument with the next character of the -- input stream | SP_EOF Bool -- unify the argument with True if we are at the end -- of the input stream, otherwise with False | SP_Close -- close the input/output streams --- Opens a new connection to a process that executes a shell command. --- @param cmd - the shell command to be executed --- @return the output/input stream (represented as a stream port) --- that is connected to the standard input/output of the process --- performing the execution of cmd. openProcessPort :: String -> IO (Port SP_Msg) openProcessPort cmd = prim_openProcessPort $## cmd prim_openProcessPort :: String -> IO (Port SP_Msg) prim_openProcessPort external --- Opens an external port with a symbolic name. --- @param portname - the symbolic name under which the port is accessible --- (any string without occurrences of '@') --- @return the stream of incoming messages at this port openNamedPort :: String -> IO [_] openNamedPort name = do stream <- openPortOnSocket socketnr portnr -- open new port registerPort name socketnr portnr return stream where socketnr,portnr free --- Waits for connection to an external port. --- In contrast to connectPort, this action waits until --- the external port has been registered with its symbolic name. --- @param waittime - the time to wait before retrying (in milliseconds) --- @param action - I/O action to be executed before each wait cycle --- @param retries - number of retries before giving up (-1 = retry forever) --- @param portname - the symbolic name of the external port --- (must be either of the form "name@machine" or "name" --- where the latter is a shorthand for "name@localhost") --- @return Nothing (if connection is not possible within the given limits) --- or (Just p) where p is a port with the symbolic name portname connectPortRepeat :: Int -> IO _ -> Int -> String -> IO (Maybe (Port _)) connectPortRepeat waittime action retries nameAtHost = do let (name,atHost) = break (=='@') nameAtHost host = if atHost=="" then "localhost" else tail atHost -- check whether remote CPNS demon is alive: alive <- cpnsAlive waittime host if not alive then tryAgain else do -- get remote socket/port numbers: (snr,pnr) <- getPortInfo name host if snr==0 then tryAgain else connectPortAtSocket snr pnr host >>= return . Just where tryAgain = if retries==0 then return Nothing else do action sleep (ms2s waittime) connectPortRepeat waittime action (decr retries) nameAtHost ms2s n = let mn = n `div` 1000 in if mn==0 then 1 else mn decr n = if n<0 then n else n-1 --- Waits for connection to an external port and return the connected port. --- This action waits (possibly forever) until the external port is --- registered. --- @param portname - the symbolic name of the external port --- (must be either of the form "name@host" or "name" --- where the latter is a shorthand for "name@localhost") --- @return a port with the symbolic name portname connectPortWait :: String -> IO (Port _) connectPortWait nameAtHost = do Just port <- connectPortRepeat 1000 done (-1) nameAtHost return port --- Connects to an external port. The external port must be already --- registered, otherwise an error is reported. --- @param portname - the symbolic name of the external port --- (must be either of the form "name@host" or "name" --- where the latter is a shorthand for "name@localhost") --- @return a port with the symbolic name portname connectPort :: String -> IO (Port _) connectPort nameAtHost = do let (name,atHost) = break (=='@') nameAtHost host = if atHost=="" then "localhost" else tail atHost -- get remote socket/port numbers: (snr,pnr) <- getPortInfo name host if snr==0 then error ("connectPort: Port \""++name++"@"++host++ "\" is not registered!") else done connectPortAtSocket snr pnr host --- This function implements a committed choice over the receiving --- of messages via a stream port and an external port. --- --- Note that the implementation of choiceSPEP works only with --- Sicstus-Prolog 3.8.5 or higher (due to a bug in previous versions --- of Sicstus-Prolog). --- --- @param sp - a stream port sp --- @param ms - a stream of messages received via an external port --- @return (Left s) if s is an input line received --- at the stream port (via SP_GetLine) or --- --- (Right ms) if the stream ms is instantiated --- with at least one new message at the head choiceSPEP :: Port SP_Msg -> [msg] -> Either String [msg] choiceSPEP p ms = (prim_choiceSPEP $# p) ms prim_choiceSPEP :: Port SP_Msg -> [msg] -> Either String [msg] prim_choiceSPEP external --- Creates a new object (of type State -> [msg] -> Bool) --- with an initial state and a port to which messages for this object --- can be sent. --- --- @param object - an object template --- @param state - the initial state of the object --- @param port - a free variable which will be constrained to the port --- for sending messages to the object newObject :: (state -> [msg] -> Bool) -> state -> Port msg -> Bool newObject object state port = let msgs free in openPort port msgs &> object state (map ensureNotFree (ensureSpine msgs)) --- Creates a new object (of type State -> [msg] -> Bool) --- with a symbolic port name to which messages for this object can be sent. --- @param object - an object template --- @param state - the initial state of the object --- @param portname - the symbolic name under which the object's port is --- accessible (any string without occurrences of '@') newNamedObject :: (state -> [_] -> Bool) -> state -> String -> IO () newNamedObject object state portname = do msgs <- openNamedPort portname doSolve (object state msgs) --- Runs a new server (of type [msg] -> IO a) on a named port --- to which messages can be sent. --- @param server - a server function that processes incoming messages --- @param portname - the symbolic name under which the server's port is --- accessible (any string without occurrences of '@') runNamedServer :: ([_] -> IO a) -> String -> IO a runNamedServer server portname = do msgs <- openNamedPort portname server msgs ------------------------------------------------------------------------------ -- The following predefined actions are not intended for application programs. -- They are the basis to implement ports with symbolic names -- via a name server (see library CPNS). -- (openPortOnSocket snr pnr) is an action which opens an external port -- on socket number snr with internal port number pnr and returns -- the stream of incoming messages. -- snr and pnr are allowed to be unbound: in this case they will be bound to the -- numbers associated to a free port openPortOnSocket :: Int -> Int -> IO [_] openPortOnSocket snr pnr = (prim_openPortOnSocket $! snr) $! pnr prim_openPortOnSocket :: Int -> Int -> IO [_] prim_openPortOnSocket external -- The internal function that reads a port stream lazily. basicServerLoop :: Port a -> [a] basicServerLoop external -- (connectPortAtSocket snr pnr host) is an action which returns a port that -- has been opened at with socket number and port number connectPortAtSocket :: Int -> Int -> String -> IO (Port _) connectPortAtSocket snr pnr host = ((prim_connectPortAtSocket $# snr) $# pnr) $## host prim_connectPortAtSocket :: Int -> Int -> String -> IO (Port _) prim_connectPortAtSocket external -- end of module Ports curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Ports.prim_c2p000066400000000000000000000026431305333611600240010ustar00rootroot00000000000000 prim_ports prim_openPort prim_ports prim_basicServerLoop[raw] prim_ports prim_sendPort[raw] prim_ports prim_after[raw] prim_ports prim_openProcessPort prim_ports prim_ping prim_ports prim_timeoutOnStream[raw] prim_ports prim_openPortOnSocket prim_ports prim_connectPortAtSocket prim_ports prim_choiceSPEP[raw] curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Prelude.curry000066400000000000000000000642251305333611600237270ustar00rootroot00000000000000---------------------------------------------------------------------------- --- The standard prelude of Curry. --- All top-level functions defined in this module --- are always available in any Curry program. --- --- @category general ---------------------------------------------------------------------------- {-# OPTIONS_CYMAKE -Wno-incomplete-patterns -Wno-overlapping #-} module Prelude where -- Lines beginning with "--++" are part of the prelude -- but cannot parsed by the compiler -- Infix operator declarations: infixl 9 !! infixr 9 . infixl 7 *, `div`, `mod`, `quot`, `rem` infixl 6 +, - -- infixr 5 : -- declared together with list infixr 5 ++ infix 4 =:=, ==, /=, <, >, <=, >=, =:<= infix 4 `elem`, `notElem` infixr 3 && infixr 2 || infixl 1 >>, >>= infixr 0 $, $!, $!!, $#, $##, `seq`, &, &>, ? -- externally defined types for numbers and characters data Int data Float data Char type String = [Char] -- Some standard combinators: --- Function composition. (.) :: (b -> c) -> (a -> b) -> (a -> c) f . g = \x -> f (g x) --- Identity function. id :: a -> a id x = x --- Constant function. const :: a -> _ -> a const x _ = x --- Converts an uncurried function to a curried function. curry :: ((a,b) -> c) -> a -> b -> c curry f a b = f (a,b) --- Converts an curried function to a function on pairs. uncurry :: (a -> b -> c) -> (a,b) -> c uncurry f (a,b) = f a b --- (flip f) is identical to f but with the order of arguments reversed. flip :: (a -> b -> c) -> b -> a -> c flip f x y = f y x --- Repeats application of a function until a predicate holds. until :: (a -> Bool) -> (a -> a) -> a -> a until p f x = if p x then x else until p f (f x) --- Evaluates the first argument to head normal form (which could also --- be a free variable) and returns the second argument. seq :: _ -> a -> a x `seq` y = const y $! x --- Evaluates the argument to head normal form and returns it. --- Suspends until the result is bound to a non-variable term. ensureNotFree :: a -> a ensureNotFree external --- Evaluates the argument to spine form and returns it. --- Suspends until the result is bound to a non-variable spine. ensureSpine :: [a] -> [a] ensureSpine l = ensureList (ensureNotFree l) where ensureList [] = [] ensureList (x:xs) = x : ensureSpine xs --- Right-associative application. ($) :: (a -> b) -> a -> b f $ x = f x --- Right-associative application with strict evaluation of its argument --- to head normal form. ($!) :: (a -> b) -> a -> b ($!) external --- Right-associative application with strict evaluation of its argument --- to normal form. ($!!) :: (a -> b) -> a -> b ($!!) external --- Right-associative application with strict evaluation of its argument --- to a non-variable term. ($#) :: (a -> b) -> a -> b f $# x = f $! (ensureNotFree x) --- Right-associative application with strict evaluation of its argument --- to ground normal form. ($##) :: (a -> b) -> a -> b ($##) external --- Aborts the execution with an error message. error :: String -> _ error x = prim_error $## x prim_error :: String -> _ prim_error external --- A non-reducible polymorphic function. --- It is useful to express a failure in a search branch of the execution. --- It could be defined by: `failed = head []` failed :: _ failed external -- Boolean values -- already defined as builtin, since it is required for if-then-else data Bool = False | True --- Sequential conjunction on Booleans. (&&) :: Bool -> Bool -> Bool True && x = x False && _ = False --- Sequential disjunction on Booleans. (||) :: Bool -> Bool -> Bool True || _ = True False || x = x --- Negation on Booleans. not :: Bool -> Bool not True = False not False = True --- Useful name for the last condition in a sequence of conditional equations. otherwise :: Bool otherwise = True --- The standard conditional. It suspends if the condition is a free variable. if_then_else :: Bool -> a -> a -> a if_then_else b t f = case b of True -> t False -> f --- Enforce a Boolean condition to be true. --- The computation fails if the argument evaluates to `False`. solve :: Bool -> Bool solve True = True --- Conditional expression. --- An expression like `(c &> e)` is evaluated by evaluating the first --- argument to `True` and then evaluating `e`. --- The expression has no value if the condition does not evaluate to `True`. (&>) :: Bool -> a -> a True &> x = x --- Equality on finite ground data terms. (==) :: a -> a -> Bool (==) external --- Disequality. (/=) :: a -> a -> Bool x /= y = not (x==y) --- The equational constraint. --- `(e1 =:= e2)` is satisfiable if both sides `e1` and `e2` can be --- reduced to a unifiable data term (i.e., a term without defined --- function symbols). (=:=) :: a -> a -> Bool (=:=) external --- Concurrent conjunction. --- An expression like `(c1 & c2)` is evaluated by evaluating --- the `c1` and `c2` in a concurrent manner. (&) :: Bool -> Bool -> Bool (&) external --- Ordering type. Useful as a result of comparison functions. data Ordering = LT | EQ | GT --- Comparison of arbitrary ground data terms. --- Data constructors are compared in the order of their definition --- in the datatype declarations and recursively in the arguments. compare :: a -> a -> Ordering compare x y | x == y = EQ | x <= y = LT | otherwise = GT --- Less-than on ground data terms. (<) :: a -> a -> Bool x < y = not (y <= x) --- Greater-than on ground data terms. (>) :: a -> a -> Bool x > y = not (x <= y) --- Less-or-equal on ground data terms. (<=) :: a -> a -> Bool (<=) external --- Greater-or-equal on ground data terms. (>=) :: a -> a -> Bool x >= y = not (x < y) --- Maximum of ground data terms. max :: a -> a -> a max x y = if x >= y then x else y --- Minimum of ground data terms. min :: a -> a -> a min x y = if x <= y then x else y -- Pairs --++ data (a,b) = (a,b) --- Selects the first component of a pair. fst :: (a,_) -> a fst (x,_) = x --- Selects the second component of a pair. snd :: (_,b) -> b snd (_,y) = y -- Unit type --++ data () = () -- Lists --++ data [a] = [] | a : [a] --- Computes the first element of a list. head :: [a] -> a head (x:_) = x --- Computes the remaining elements of a list. tail :: [a] -> [a] tail (_:xs) = xs --- Is a list empty? null :: [_] -> Bool null [] = True null (_:_) = False --- Concatenates two lists. --- Since it is flexible, it could be also used to split a list --- into two sublists etc. (++) :: [a] -> [a] -> [a] [] ++ ys = ys (x:xs) ++ ys = x : xs++ys --- Computes the length of a list. length :: [_] -> Int length xs = len xs 0 where len [] n = n len (_:ys) n = let np1 = n + 1 in len ys $!! np1 --length [] = 0 --length (_:xs) = 1 + length xs --- List index (subscript) operator, head has index 0. (!!) :: [a] -> Int -> a (x:xs) !! n | n==0 = x | n>0 = xs !! (n-1) --- Map a function on all elements of a list. map :: (a->b) -> [a] -> [b] map _ [] = [] map f (x:xs) = f x : map f xs --- Accumulates all list elements by applying a binary operator from --- left to right. Thus, --- --- foldl f z [x1,x2,...,xn] = (...((z `f` x1) `f` x2) ...) `f` xn foldl :: (a -> b -> a) -> a -> [b] -> a foldl _ z [] = z foldl f z (x:xs) = foldl f (f z x) xs --- Accumulates a non-empty list from left to right. foldl1 :: (a -> a -> a) -> [a] -> a foldl1 f (x:xs) = foldl f x xs --- Accumulates all list elements by applying a binary operator from --- right to left. Thus, --- --- foldr f z [x1,x2,...,xn] = (x1 `f` (x2 `f` ... (xn `f` z)...)) foldr :: (a->b->b) -> b -> [a] -> b foldr _ z [] = z foldr f z (x:xs) = f x (foldr f z xs) --- Accumulates a non-empty list from right to left: foldr1 :: (a -> a -> a) -> [a] -> a foldr1 _ [x] = x foldr1 f (x1:x2:xs) = f x1 (foldr1 f (x2:xs)) --- Filters all elements satisfying a given predicate in a list. filter :: (a -> Bool) -> [a] -> [a] filter _ [] = [] filter p (x:xs) = if p x then x : filter p xs else filter p xs --- Joins two lists into one list of pairs. If one input list is shorter than --- the other, the additional elements of the longer list are discarded. zip :: [a] -> [b] -> [(a,b)] zip [] _ = [] zip (_:_) [] = [] zip (x:xs) (y:ys) = (x,y) : zip xs ys --- Joins three lists into one list of triples. If one input list is shorter --- than the other, the additional elements of the longer lists are discarded. zip3 :: [a] -> [b] -> [c] -> [(a,b,c)] zip3 [] _ _ = [] zip3 (_:_) [] _ = [] zip3 (_:_) (_:_) [] = [] zip3 (x:xs) (y:ys) (z:zs) = (x,y,z) : zip3 xs ys zs --- Joins two lists into one list by applying a combination function to --- corresponding pairs of elements. Thus `zip = zipWith (,)` zipWith :: (a->b->c) -> [a] -> [b] -> [c] zipWith _ [] _ = [] zipWith _ (_:_) [] = [] zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys --- Joins three lists into one list by applying a combination function to --- corresponding triples of elements. Thus `zip3 = zipWith3 (,,)` zipWith3 :: (a->b->c->d) -> [a] -> [b] -> [c] -> [d] zipWith3 _ [] _ _ = [] zipWith3 _ (_:_) [] _ = [] zipWith3 _ (_:_) (_:_) [] = [] zipWith3 f (x:xs) (y:ys) (z:zs) = f x y z : zipWith3 f xs ys zs --- Transforms a list of pairs into a pair of lists. unzip :: [(a,b)] -> ([a],[b]) unzip [] = ([],[]) unzip ((x,y):ps) = (x:xs,y:ys) where (xs,ys) = unzip ps --- Transforms a list of triples into a triple of lists. unzip3 :: [(a,b,c)] -> ([a],[b],[c]) unzip3 [] = ([],[],[]) unzip3 ((x,y,z):ts) = (x:xs,y:ys,z:zs) where (xs,ys,zs) = unzip3 ts --- Concatenates a list of lists into one list. concat :: [[a]] -> [a] concat l = foldr (++) [] l --- Maps a function from elements to lists and merges the result into one list. concatMap :: (a -> [b]) -> [a] -> [b] concatMap f = concat . map f --- Infinite list of repeated applications of a function f to an element x. --- Thus, `iterate f x = [x, f x, f (f x),...]` iterate :: (a -> a) -> a -> [a] iterate f x = x : iterate f (f x) --- Infinite list where all elements have the same value. --- Thus, `repeat x = [x, x, x,...]` repeat :: a -> [a] repeat x = x : repeat x --- List of length n where all elements have the same value. replicate :: Int -> a -> [a] replicate n x = take n (repeat x) --- Returns prefix of length n. take :: Int -> [a] -> [a] take n l = if n<=0 then [] else takep n l where takep _ [] = [] takep m (x:xs) = x : take (m-1) xs --- Returns suffix without first n elements. drop :: Int -> [a] -> [a] drop n xs = if n<=0 then xs else case xs of [] -> [] (_:ys) -> drop (n-1) ys --- (splitAt n xs) is equivalent to (take n xs, drop n xs) splitAt :: Int -> [a] -> ([a],[a]) splitAt n l = if n<=0 then ([],l) else splitAtp n l where splitAtp _ [] = ([],[]) splitAtp m (x:xs) = let (ys,zs) = splitAt (m-1) xs in (x:ys,zs) --- Returns longest prefix with elements satisfying a predicate. takeWhile :: (a -> Bool) -> [a] -> [a] takeWhile _ [] = [] takeWhile p (x:xs) = if p x then x : takeWhile p xs else [] --- Returns suffix without takeWhile prefix. dropWhile :: (a -> Bool) -> [a] -> [a] dropWhile _ [] = [] dropWhile p (x:xs) = if p x then dropWhile p xs else x:xs --- (span p xs) is equivalent to (takeWhile p xs, dropWhile p xs) span :: (a -> Bool) -> [a] -> ([a],[a]) span _ [] = ([],[]) span p (x:xs) | p x = let (ys,zs) = span p xs in (x:ys, zs) | otherwise = ([],x:xs) --- (break p xs) is equivalent to (takeWhile (not.p) xs, dropWhile (not.p) xs). --- Thus, it breaks a list at the first occurrence of an element satisfying p. break :: (a -> Bool) -> [a] -> ([a],[a]) break p = span (not . p) --- Breaks a string into a list of lines where a line is terminated at a --- newline character. The resulting lines do not contain newline characters. lines :: String -> [String] lines [] = [] lines (x:xs) = let (l,xs_l) = splitline (x:xs) in l : lines xs_l where splitline [] = ([],[]) splitline (c:cs) = if c=='\n' then ([],cs) else let (ds,es) = splitline cs in (c:ds,es) --- Concatenates a list of strings with terminating newlines. unlines :: [String] -> String unlines ls = concatMap (++"\n") ls --- Breaks a string into a list of words where the words are delimited by --- white spaces. words :: String -> [String] words s = let s1 = dropWhile isSpace s in if s1=="" then [] else let (w,s2) = break isSpace s1 in w : words s2 where isSpace c = c == ' ' || c == '\t' || c == '\n' || c == '\r' --- Concatenates a list of strings with a blank between two strings. unwords :: [String] -> String unwords ws = if ws==[] then [] else foldr1 (\w s -> w ++ ' ':s) ws --- Reverses the order of all elements in a list. reverse :: [a] -> [a] reverse = foldl (flip (:)) [] --- Computes the conjunction of a Boolean list. and :: [Bool] -> Bool and = foldr (&&) True --- Computes the disjunction of a Boolean list. or :: [Bool] -> Bool or = foldr (||) False --- Is there an element in a list satisfying a given predicate? any :: (a -> Bool) -> [a] -> Bool any p = or . map p --- Is a given predicate satisfied by all elements in a list? all :: (a -> Bool) -> [a] -> Bool all p = and . map p --- Element of a list? elem :: a -> [a] -> Bool elem x = any (x==) --- Not element of a list? notElem :: a -> [a] -> Bool notElem x = all (x/=) --- Looks up a key in an association list. lookup :: a -> [(a,b)] -> Maybe b lookup _ [] = Nothing lookup k ((x,y):xys) | k==x = Just y | otherwise = lookup k xys --- Generates an infinite sequence of ascending integers. enumFrom :: Int -> [Int] -- [n..] enumFrom n = n : enumFrom (n+1) --- Generates an infinite sequence of integers with a particular in/decrement. enumFromThen :: Int -> Int -> [Int] -- [n1,n2..] enumFromThen n1 n2 = iterate ((n2-n1)+) n1 --- Generates a sequence of ascending integers. enumFromTo :: Int -> Int -> [Int] -- [n..m] enumFromTo n m = if n>m then [] else n : enumFromTo (n+1) m --- Generates a sequence of integers with a particular in/decrement. enumFromThenTo :: Int -> Int -> Int -> [Int] -- [n1,n2..m] enumFromThenTo n1 n2 m = takeWhile p (enumFromThen n1 n2) where p x | n2 >= n1 = (x <= m) | otherwise = (x >= m) --- Converts a character into its ASCII value. ord :: Char -> Int ord c = prim_ord $# c prim_ord :: Char -> Int prim_ord external --- Converts a Unicode value into a character, fails iff the value is out of bounds chr :: Int -> Char chr n | n >= 0 = prim_chr $# n -- chr n | n < 0 || n > 1114111 = failed -- | otherwise = prim_chr $# n prim_chr :: Int -> Char prim_chr external -- Types of primitive arithmetic functions and predicates --- Adds two integers. (+) :: Int -> Int -> Int (+) external --- Subtracts two integers. (-) :: Int -> Int -> Int (-) external --- Multiplies two integers. (*) :: Int -> Int -> Int (*) external --- Integer division. The value is the integer quotient of its arguments --- and always truncated towards negative infinity. --- Thus, the value of 13 `div` 5 is 2, --- and the value of -15 `div` 4 is -4. div :: Int -> Int -> Int div external --- Integer remainder. The value is the remainder of the integer division and --- it obeys the rule x `mod` y = x - y * (x `div` y). --- Thus, the value of 13 `mod` 5 is 3, --- and the value of -15 `mod` 4 is -3. mod :: Int -> Int -> Int mod external --- Returns an integer (quotient,remainder) pair. --- The value is the integer quotient of its arguments --- and always truncated towards negative infinity. divMod :: Int -> Int -> (Int, Int) divMod external --- Integer division. The value is the integer quotient of its arguments --- and always truncated towards zero. --- Thus, the value of 13 `quot` 5 is 2, --- and the value of -15 `quot` 4 is -3. quot :: Int -> Int -> Int quot external --- Integer remainder. The value is the remainder of the integer division and --- it obeys the rule x `rem` y = x - y * (x `quot` y). --- Thus, the value of 13 `rem` 5 is 3, --- and the value of -15 `rem` 4 is -3. rem :: Int -> Int -> Int rem external --- Returns an integer (quotient,remainder) pair. --- The value is the integer quotient of its arguments --- and always truncated towards zero. quotRem :: Int -> Int -> (Int, Int) quotRem external --- Unary minus. Usually written as "- e". negate :: Int -> Int negate x = 0 - x --- Unary minus on Floats. Usually written as "-e". negateFloat :: Float -> Float negateFloat external -- Constraints (included for backward compatibility) type Success = Bool --- The always satisfiable constraint. success :: Success success = True -- Maybe type data Maybe a = Nothing | Just a maybe :: b -> (a -> b) -> Maybe a -> b maybe n _ Nothing = n maybe _ f (Just x) = f x -- Either type data Either a b = Left a | Right b either :: (a -> c) -> (b -> c) -> Either a b -> c either f _ (Left x) = f x either _ g (Right x) = g x -- Monadic IO data IO _ -- conceptually: World -> (a,World) --- Sequential composition of actions. --- @param a - An action --- @param fa - A function from a value into an action --- @return An action that first performs a (yielding result r) --- and then performs (fa r) (>>=) :: IO a -> (a -> IO b) -> IO b (>>=) external --- The empty action that directly returns its argument. return :: a -> IO a return external --- Sequential composition of actions. --- @param a1 - An action --- @param a2 - An action --- @return An action that first performs a1 and then a2 (>>) :: IO _ -> IO b -> IO b a >> b = a >>= (\_ -> b) --- The empty action that returns nothing. done :: IO () done = return () --- An action that puts its character argument on standard output. putChar :: Char -> IO () putChar c = prim_putChar $## c prim_putChar :: Char -> IO () prim_putChar external --- An action that reads a character from standard output and returns it. getChar :: IO Char getChar external --- An action that (lazily) reads a file and returns its contents. readFile :: String -> IO String readFile f = prim_readFile $## f prim_readFile :: String -> IO String prim_readFile external --- An action that writes a file. --- @param filename - The name of the file to be written. --- @param contents - The contents to be written to the file. writeFile :: String -> String -> IO () writeFile f s = (prim_writeFile $## f) $## s prim_writeFile :: String -> String -> IO () prim_writeFile external --- An action that appends a string to a file. --- It behaves like writeFile if the file does not exist. --- @param filename - The name of the file to be written. --- @param contents - The contents to be appended to the file. appendFile :: String -> String -> IO () appendFile f s = (prim_appendFile $## f) $## s prim_appendFile :: String -> String -> IO () prim_appendFile external --- Action to print a string on stdout. putStr :: String -> IO () putStr [] = done putStr (c:cs) = putChar c >> putStr cs --- Action to print a string with a newline on stdout. putStrLn :: String -> IO () putStrLn cs = putStr cs >> putChar '\n' --- Action to read a line from stdin. getLine :: IO String getLine = do c <- getChar if c=='\n' then return [] else do cs <- getLine return (c:cs) ---------------------------------------------------------------------------- -- Error handling in the I/O monad: --- The (abstract) type of error values. --- Currently, it distinguishes between general IO errors, --- user-generated errors (see 'userError'), failures and non-determinism --- errors during IO computations. These errors can be caught by 'catch' --- and shown by 'showError'. --- Each error contains a string shortly explaining the error. --- This type might be extended in the future to distinguish --- further error situations. data IOError = IOError String -- normal IO error | UserError String -- user-specified error | FailError String -- failing computation | NondetError String -- non-deterministic computation --- A user error value is created by providing a description of the --- error situation as a string. userError :: String -> IOError userError s = UserError s --- Raises an I/O exception with a given error value. ioError :: IOError -> IO _ ioError err = prim_ioError $## err prim_ioError :: IOError -> IO _ prim_ioError external --- Shows an error values as a string. showError :: IOError -> String showError (IOError s) = "i/o error: " ++ s showError (UserError s) = "user error: " ++ s showError (FailError s) = "fail error: " ++ s showError (NondetError s) = "nondet error: " ++ s --- Catches a possible error or failure during the execution of an --- I/O action. `(catch act errfun)` executes the I/O action --- `act`. If an exception or failure occurs --- during this I/O action, the function `errfun` is applied --- to the error value. catch :: IO a -> (IOError -> IO a) -> IO a catch external ---------------------------------------------------------------------------- --- Converts an arbitrary term into an external string representation. show :: _ -> String show x = prim_show $## x prim_show :: _ -> String prim_show external --- Converts a term into a string and prints it. print :: _ -> IO () print t = putStrLn (show t) --- Solves a constraint as an I/O action. --- Note: the constraint should be always solvable in a deterministic way doSolve :: Bool -> IO () doSolve b | b = done -- IO monad auxiliary functions: --- Executes a sequence of I/O actions and collects all results in a list. sequenceIO :: [IO a] -> IO [a] sequenceIO [] = return [] sequenceIO (c:cs) = do x <- c xs <- sequenceIO cs return (x:xs) --- Executes a sequence of I/O actions and ignores the results. sequenceIO_ :: [IO _] -> IO () sequenceIO_ = foldr (>>) done --- Maps an I/O action function on a list of elements. --- The results of all I/O actions are collected in a list. mapIO :: (a -> IO b) -> [a] -> IO [b] mapIO f = sequenceIO . map f --- Maps an I/O action function on a list of elements. --- The results of all I/O actions are ignored. mapIO_ :: (a -> IO _) -> [a] -> IO () mapIO_ f = sequenceIO_ . map f --- Folds a list of elements using an binary I/O action and a value --- for the empty list. foldIO :: (a -> b -> IO a) -> a -> [b] -> IO a foldIO _ a [] = return a foldIO f a (x:xs) = f a x >>= \fax -> foldIO f fax xs --- Apply a pure function to the result of an I/O action. liftIO :: (a -> b) -> IO a -> IO b liftIO f m = m >>= return . f --- Like `mapIO`, but with flipped arguments. --- --- This can be useful if the definition of the function is longer --- than those of the list, like in --- --- forIO [1..10] $ \n -> do --- ... forIO :: [a] -> (a -> IO b) -> IO [b] forIO xs f = mapIO f xs --- Like `mapIO_`, but with flipped arguments. --- --- This can be useful if the definition of the function is longer --- than those of the list, like in --- --- forIO_ [1..10] $ \n -> do --- ... forIO_ :: [a] -> (a -> IO b) -> IO () forIO_ xs f = mapIO_ f xs --- Performs an `IO` action unless the condition is met. unless :: Bool -> IO () -> IO () unless p act = if p then done else act --- Performs an `IO` action when the condition is met. when :: Bool -> IO () -> IO () when p act = if p then act else done ---------------------------------------------------------------- -- Non-determinism and free variables: --- Non-deterministic choice _par excellence_. --- The value of `x ? y` is either `x` or `y`. --- @param x - The right argument. --- @param y - The left argument. --- @return either `x` or `y` non-deterministically. (?) :: a -> a -> a x ? _ = x _ ? y = y -- Returns non-deterministically any element of a list. anyOf :: [a] -> a anyOf = foldr1 (?) --- Evaluates to a fresh free variable. unknown :: _ unknown = let x free in x ---------------------------------------------------------------- --- Identity type synonym used to mark deterministic operations. type DET a = a --- Identity function used by the partial evaluator --- to mark expressions to be partially evaluated. PEVAL :: a -> a PEVAL x = x --- Evaluates the argument to normal form and returns it. normalForm :: a -> a normalForm x = id $!! x --- Evaluates the argument to ground normal form and returns it. --- Suspends as long as the normal form of the argument is not ground. groundNormalForm :: a -> a groundNormalForm x = id $## x -- Only for internal use: -- Representation of higher-order applications in FlatCurry. apply :: (a -> b) -> a -> b apply external -- Only for internal use: -- Representation of conditional rules in FlatCurry. cond :: Bool -> a -> a cond external --- Non-strict equational constraint. Used to implement functional patterns. (=:<=) :: a -> a -> Bool (=:<=) external -- the end of the standard prelude curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Prelude.curry.pakcs000066400000000000000000000663721305333611600250340ustar00rootroot00000000000000---------------------------------------------------------------------------- --- The standard prelude of Curry. --- All top-level functions defined in this module --- are always available in any Curry program. --- --- @category general ---------------------------------------------------------------------------- {-# OPTIONS_CYMAKE -Wno-incomplete-patterns -Wno-overlapping #-} module Prelude where -- Lines beginning with "--++" are part of the prelude -- but cannot parsed by the compiler -- Infix operator declarations: infixl 9 !! infixr 9 . infixl 7 *, `div`, `mod`, `quot`, `rem` infixl 6 +, - -- infixr 5 : -- declared together with list infixr 5 ++ infix 4 =:=, ==, /=, <, >, <=, >=, =:<=, =:<<= infix 4 `elem`, `notElem` infixr 3 && infixr 2 || infixl 1 >>, >>= infixr 0 $, $!, $!!, $#, $##, `seq`, &, &>, ? -- externally defined types for numbers and characters data Int data Float data Char type String = [Char] -- Some standard combinators: --- Function composition. (.) :: (b -> c) -> (a -> b) -> (a -> c) f . g = \x -> f (g x) --- Identity function. id :: a -> a id x = x --- Constant function. const :: a -> _ -> a const x _ = x --- Converts an uncurried function to a curried function. curry :: ((a,b) -> c) -> a -> b -> c curry f a b = f (a,b) --- Converts an curried function to a function on pairs. uncurry :: (a -> b -> c) -> (a,b) -> c uncurry f (a,b) = f a b --- (flip f) is identical to f but with the order of arguments reversed. flip :: (a -> b -> c) -> b -> a -> c flip f x y = f y x --- Repeats application of a function until a predicate holds. until :: (a -> Bool) -> (a -> a) -> a -> a until p f x = if p x then x else until p f (f x) --- Evaluates the first argument to head normal form (which could also --- be a free variable) and returns the second argument. seq :: _ -> a -> a x `seq` y = const y $! x --- Evaluates the argument to head normal form and returns it. --- Suspends until the result is bound to a non-variable term. ensureNotFree :: a -> a ensureNotFree external --- Evaluates the argument to spine form and returns it. --- Suspends until the result is bound to a non-variable spine. ensureSpine :: [a] -> [a] ensureSpine l = ensureList (ensureNotFree l) where ensureList [] = [] ensureList (x:xs) = x : ensureSpine xs --- Right-associative application. ($) :: (a -> b) -> a -> b f $ x = f x --- Right-associative application with strict evaluation of its argument --- to head normal form. ($!) :: (a -> b) -> a -> b ($!) external --- Right-associative application with strict evaluation of its argument --- to normal form. ($!!) :: (a -> b) -> a -> b ($!!) external --- Right-associative application with strict evaluation of its argument --- to a non-variable term. ($#) :: (a -> b) -> a -> b f $# x = f $! (ensureNotFree x) --- Right-associative application with strict evaluation of its argument --- to ground normal form. ($##) :: (a -> b) -> a -> b ($##) external --- Aborts the execution with an error message. error :: String -> _ error x = prim_error $## x prim_error :: String -> _ prim_error external --- A non-reducible polymorphic function. --- It is useful to express a failure in a search branch of the execution. --- It could be defined by: `failed = head []` failed :: _ failed external -- Boolean values -- already defined as builtin, since it is required for if-then-else data Bool = False | True --- Sequential conjunction on Booleans. (&&) :: Bool -> Bool -> Bool True && x = x False && _ = False --- Sequential disjunction on Booleans. (||) :: Bool -> Bool -> Bool True || _ = True False || x = x --- Negation on Booleans. not :: Bool -> Bool not True = False not False = True --- Useful name for the last condition in a sequence of conditional equations. otherwise :: Bool otherwise = True --- The standard conditional. It suspends if the condition is a free variable. if_then_else :: Bool -> a -> a -> a if_then_else b t f = case b of True -> t False -> f --- Enforce a Boolean condition to be true. --- The computation fails if the argument evaluates to `False`. solve :: Bool -> Bool solve True = True --- Conditional expression. --- An expression like `(c &> e)` is evaluated by evaluating the first --- argument to `True` and then evaluating `e`. --- The expression has no value if the condition does not evaluate to `True`. (&>) :: Bool -> a -> a True &> x = x --- Equality on finite ground data terms. (==) :: a -> a -> Bool (==) external --- Disequality. (/=) :: a -> a -> Bool x /= y = not (x==y) --- The equational constraint. --- `(e1 =:= e2)` is satisfiable if both sides `e1` and `e2` can be --- reduced to a unifiable data term (i.e., a term without defined --- function symbols). (=:=) :: a -> a -> Bool (=:=) external --- Concurrent conjunction. --- An expression like `(c1 & c2)` is evaluated by evaluating --- the `c1` and `c2` in a concurrent manner. (&) :: Bool -> Bool -> Bool (&) external --- Ordering type. Useful as a result of comparison functions. data Ordering = LT | EQ | GT --- Comparison of arbitrary ground data terms. --- Data constructors are compared in the order of their definition --- in the datatype declarations and recursively in the arguments. compare :: a -> a -> Ordering compare external --- Less-than on ground data terms. (<) :: a -> a -> Bool x < y = case compare x y of LT -> True _ -> False --- Greater-than on ground data terms. (>) :: a -> a -> Bool x > y = case compare x y of GT -> True _ -> False --- Less-or-equal on ground data terms. (<=) :: a -> a -> Bool x <= y = not (x > y) --- Greater-or-equal on ground data terms. (>=) :: a -> a -> Bool x >= y = not (x < y) --- Maximum of ground data terms. max :: a -> a -> a max x y = if x >= y then x else y --- Minimum of ground data terms. min :: a -> a -> a min x y = if x <= y then x else y -- Pairs --++ data (a,b) = (a,b) --- Selects the first component of a pair. fst :: (a,_) -> a fst (x,_) = x --- Selects the second component of a pair. snd :: (_,b) -> b snd (_,y) = y -- Unit type --++ data () = () -- Lists --++ data [a] = [] | a : [a] --- Computes the first element of a list. head :: [a] -> a head (x:_) = x --- Computes the remaining elements of a list. tail :: [a] -> [a] tail (_:xs) = xs --- Is a list empty? null :: [_] -> Bool null [] = True null (_:_) = False --- Concatenates two lists. --- Since it is flexible, it could be also used to split a list --- into two sublists etc. (++) :: [a] -> [a] -> [a] [] ++ ys = ys (x:xs) ++ ys = x : xs++ys --- Computes the length of a list. length :: [_] -> Int length [] = 0 length (_:xs) = 1 + length xs --- List index (subscript) operator, head has index 0. (!!) :: [a] -> Int -> a (x:xs) !! n | n==0 = x | n>0 = xs !! (n-1) --- Map a function on all elements of a list. map :: (a->b) -> [a] -> [b] map _ [] = [] map f (x:xs) = f x : map f xs --- Accumulates all list elements by applying a binary operator from --- left to right. Thus, --- --- foldl f z [x1,x2,...,xn] = (...((z `f` x1) `f` x2) ...) `f` xn foldl :: (a -> b -> a) -> a -> [b] -> a foldl _ z [] = z foldl f z (x:xs) = foldl f (f z x) xs --- Accumulates a non-empty list from left to right. foldl1 :: (a -> a -> a) -> [a] -> a foldl1 f (x:xs) = foldl f x xs --- Accumulates all list elements by applying a binary operator from --- right to left. Thus, --- --- foldr f z [x1,x2,...,xn] = (x1 `f` (x2 `f` ... (xn `f` z)...)) foldr :: (a->b->b) -> b -> [a] -> b foldr _ z [] = z foldr f z (x:xs) = f x (foldr f z xs) --- Accumulates a non-empty list from right to left: foldr1 :: (a -> a -> a) -> [a] -> a foldr1 _ [x] = x foldr1 f (x1:x2:xs) = f x1 (foldr1 f (x2:xs)) --- Filters all elements satisfying a given predicate in a list. filter :: (a -> Bool) -> [a] -> [a] filter _ [] = [] filter p (x:xs) = if p x then x : filter p xs else filter p xs --- Joins two lists into one list of pairs. If one input list is shorter than --- the other, the additional elements of the longer list are discarded. zip :: [a] -> [b] -> [(a,b)] zip [] _ = [] zip (_:_) [] = [] zip (x:xs) (y:ys) = (x,y) : zip xs ys --- Joins three lists into one list of triples. If one input list is shorter --- than the other, the additional elements of the longer lists are discarded. zip3 :: [a] -> [b] -> [c] -> [(a,b,c)] zip3 [] _ _ = [] zip3 (_:_) [] _ = [] zip3 (_:_) (_:_) [] = [] zip3 (x:xs) (y:ys) (z:zs) = (x,y,z) : zip3 xs ys zs --- Joins two lists into one list by applying a combination function to --- corresponding pairs of elements. Thus `zip = zipWith (,)` zipWith :: (a->b->c) -> [a] -> [b] -> [c] zipWith _ [] _ = [] zipWith _ (_:_) [] = [] zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys --- Joins three lists into one list by applying a combination function to --- corresponding triples of elements. Thus `zip3 = zipWith3 (,,)` zipWith3 :: (a->b->c->d) -> [a] -> [b] -> [c] -> [d] zipWith3 _ [] _ _ = [] zipWith3 _ (_:_) [] _ = [] zipWith3 _ (_:_) (_:_) [] = [] zipWith3 f (x:xs) (y:ys) (z:zs) = f x y z : zipWith3 f xs ys zs --- Transforms a list of pairs into a pair of lists. unzip :: [(a,b)] -> ([a],[b]) unzip [] = ([],[]) unzip ((x,y):ps) = (x:xs,y:ys) where (xs,ys) = unzip ps --- Transforms a list of triples into a triple of lists. unzip3 :: [(a,b,c)] -> ([a],[b],[c]) unzip3 [] = ([],[],[]) unzip3 ((x,y,z):ts) = (x:xs,y:ys,z:zs) where (xs,ys,zs) = unzip3 ts --- Concatenates a list of lists into one list. concat :: [[a]] -> [a] concat l = foldr (++) [] l --- Maps a function from elements to lists and merges the result into one list. concatMap :: (a -> [b]) -> [a] -> [b] concatMap f = concat . map f --- Infinite list of repeated applications of a function f to an element x. --- Thus, `iterate f x = [x, f x, f (f x),...]` iterate :: (a -> a) -> a -> [a] iterate f x = x : iterate f (f x) --- Infinite list where all elements have the same value. --- Thus, `repeat x = [x, x, x,...]` repeat :: a -> [a] repeat x = x : repeat x --- List of length n where all elements have the same value. replicate :: Int -> a -> [a] replicate n x = take n (repeat x) --- Returns prefix of length n. take :: Int -> [a] -> [a] take n l = if n<=0 then [] else takep n l where takep _ [] = [] takep m (x:xs) = x : take (m-1) xs --- Returns suffix without first n elements. drop :: Int -> [a] -> [a] drop n xs = if n<=0 then xs else case xs of [] -> [] (_:ys) -> drop (n-1) ys --- (splitAt n xs) is equivalent to (take n xs, drop n xs) splitAt :: Int -> [a] -> ([a],[a]) splitAt n l = if n<=0 then ([],l) else splitAtp n l where splitAtp _ [] = ([],[]) splitAtp m (x:xs) = let (ys,zs) = splitAt (m-1) xs in (x:ys,zs) --- Returns longest prefix with elements satisfying a predicate. takeWhile :: (a -> Bool) -> [a] -> [a] takeWhile _ [] = [] takeWhile p (x:xs) = if p x then x : takeWhile p xs else [] --- Returns suffix without takeWhile prefix. dropWhile :: (a -> Bool) -> [a] -> [a] dropWhile _ [] = [] dropWhile p (x:xs) = if p x then dropWhile p xs else x:xs --- (span p xs) is equivalent to (takeWhile p xs, dropWhile p xs) span :: (a -> Bool) -> [a] -> ([a],[a]) span _ [] = ([],[]) span p (x:xs) | p x = let (ys,zs) = span p xs in (x:ys, zs) | otherwise = ([],x:xs) --- (break p xs) is equivalent to (takeWhile (not.p) xs, dropWhile (not.p) xs). --- Thus, it breaks a list at the first occurrence of an element satisfying p. break :: (a -> Bool) -> [a] -> ([a],[a]) break p = span (not . p) --- Breaks a string into a list of lines where a line is terminated at a --- newline character. The resulting lines do not contain newline characters. lines :: String -> [String] lines [] = [] lines (x:xs) = let (l,xs_l) = splitline (x:xs) in l : lines xs_l where splitline [] = ([],[]) splitline (c:cs) = if c=='\n' then ([],cs) else let (ds,es) = splitline cs in (c:ds,es) --- Concatenates a list of strings with terminating newlines. unlines :: [String] -> String unlines ls = concatMap (++"\n") ls --- Breaks a string into a list of words where the words are delimited by --- white spaces. words :: String -> [String] words s = let s1 = dropWhile isSpace s in if s1=="" then [] else let (w,s2) = break isSpace s1 in w : words s2 where isSpace c = c == ' ' || c == '\t' || c == '\n' || c == '\r' --- Concatenates a list of strings with a blank between two strings. unwords :: [String] -> String unwords ws = if ws==[] then [] else foldr1 (\w s -> w ++ ' ':s) ws --- Reverses the order of all elements in a list. reverse :: [a] -> [a] reverse = foldl (flip (:)) [] --- Computes the conjunction of a Boolean list. and :: [Bool] -> Bool and = foldr (&&) True --- Computes the disjunction of a Boolean list. or :: [Bool] -> Bool or = foldr (||) False --- Is there an element in a list satisfying a given predicate? any :: (a -> Bool) -> [a] -> Bool any p = or . map p --- Is a given predicate satisfied by all elements in a list? all :: (a -> Bool) -> [a] -> Bool all p = and . map p --- Element of a list? elem :: a -> [a] -> Bool elem x = any (x==) --- Not element of a list? notElem :: a -> [a] -> Bool notElem x = all (x/=) --- Looks up a key in an association list. lookup :: a -> [(a,b)] -> Maybe b lookup _ [] = Nothing lookup k ((x,y):xys) | k==x = Just y | otherwise = lookup k xys --- Generates an infinite sequence of ascending integers. enumFrom :: Int -> [Int] -- [n..] enumFrom n = n : enumFrom (n+1) --- Generates an infinite sequence of integers with a particular in/decrement. enumFromThen :: Int -> Int -> [Int] -- [n1,n2..] enumFromThen n1 n2 = iterate ((n2-n1)+) n1 --- Generates a sequence of ascending integers. enumFromTo :: Int -> Int -> [Int] -- [n..m] enumFromTo n m = if n>m then [] else n : enumFromTo (n+1) m --- Generates a sequence of integers with a particular in/decrement. enumFromThenTo :: Int -> Int -> Int -> [Int] -- [n1,n2..m] enumFromThenTo n1 n2 m = takeWhile p (enumFromThen n1 n2) where p x | n2 >= n1 = (x <= m) | otherwise = (x >= m) --- Converts a character into its ASCII value. ord :: Char -> Int ord c = prim_ord $# c prim_ord :: Char -> Int prim_ord external --- Converts an ASCII value into a character. chr :: Int -> Char chr n = prim_chr $# n prim_chr :: Int -> Char prim_chr external -- Types of primitive arithmetic functions and predicates --- Adds two integers. (+) :: Int -> Int -> Int x + y = (prim_Int_plus $# y) $# x prim_Int_plus :: Int -> Int -> Int prim_Int_plus external --- Subtracts two integers. (-) :: Int -> Int -> Int x - y = (prim_Int_minus $# y) $# x prim_Int_minus :: Int -> Int -> Int prim_Int_minus external --- Multiplies two integers. (*) :: Int -> Int -> Int x * y = (prim_Int_times $# y) $# x prim_Int_times :: Int -> Int -> Int prim_Int_times external --- Integer division. The value is the integer quotient of its arguments --- and always truncated towards negative infinity. --- Thus, the value of 13 `div` 5 is 2, --- and the value of -15 `div` 4 is -4. div :: Int -> Int -> Int x `div` y = (prim_Int_div $# y) $# x prim_Int_div :: Int -> Int -> Int prim_Int_div external --- Integer remainder. The value is the remainder of the integer division and --- it obeys the rule x `mod` y = x - y * (x `div` y). --- Thus, the value of 13 `mod` 5 is 3, --- and the value of -15 `mod` 4 is -3. mod :: Int -> Int -> Int x `mod` y = (prim_Int_mod $# y) $# x prim_Int_mod :: Int -> Int -> Int prim_Int_mod external --- Returns an integer (quotient,remainder) pair. --- The value is the integer quotient of its arguments --- and always truncated towards negative infinity. divMod :: Int -> Int -> (Int, Int) divMod x y = (x `div` y, x `mod` y) --- Integer division. The value is the integer quotient of its arguments --- and always truncated towards zero. --- Thus, the value of 13 `quot` 5 is 2, --- and the value of -15 `quot` 4 is -3. quot :: Int -> Int -> Int x `quot` y = (prim_Int_quot $# y) $# x prim_Int_quot :: Int -> Int -> Int prim_Int_quot external --- Integer remainder. The value is the remainder of the integer division and --- it obeys the rule x `rem` y = x - y * (x `quot` y). --- Thus, the value of 13 `rem` 5 is 3, --- and the value of -15 `rem` 4 is -3. rem :: Int -> Int -> Int x `rem` y = (prim_Int_rem $# y) $# x prim_Int_rem :: Int -> Int -> Int prim_Int_rem external --- Returns an integer (quotient,remainder) pair. --- The value is the integer quotient of its arguments --- and always truncated towards zero. quotRem :: Int -> Int -> (Int, Int) quotRem x y = (x `quot` y, x `rem` y) --- Unary minus. Usually written as "- e". negate :: Int -> Int negate x = 0 - x --- Unary minus on Floats. Usually written as "-e". negateFloat :: Float -> Float negateFloat x = prim_negateFloat $# x prim_negateFloat :: Float -> Float prim_negateFloat external -- Constraints (included for backward compatibility) type Success = Bool --- The always satisfiable constraint. success :: Success success = True -- Maybe type data Maybe a = Nothing | Just a maybe :: b -> (a -> b) -> Maybe a -> b maybe n _ Nothing = n maybe _ f (Just x) = f x -- Either type data Either a b = Left a | Right b either :: (a -> c) -> (b -> c) -> Either a b -> c either f _ (Left x) = f x either _ g (Right x) = g x -- Monadic IO data IO _ -- conceptually: World -> (a,World) --- Sequential composition of actions. --- @param a - An action --- @param fa - A function from a value into an action --- @return An action that first performs a (yielding result r) --- and then performs (fa r) (>>=) :: IO a -> (a -> IO b) -> IO b (>>=) external --- The empty action that directly returns its argument. return :: a -> IO a return external --- Sequential composition of actions. --- @param a1 - An action --- @param a2 - An action --- @return An action that first performs a1 and then a2 (>>) :: IO _ -> IO b -> IO b a >> b = a >>= (\_ -> b) --- The empty action that returns nothing. done :: IO () done = return () --- An action that puts its character argument on standard output. putChar :: Char -> IO () putChar c = prim_putChar $# c prim_putChar :: Char -> IO () prim_putChar external --- An action that reads a character from standard output and returns it. getChar :: IO Char getChar external --- An action that (lazily) reads a file and returns its contents. readFile :: String -> IO String readFile f = prim_readFile $## f prim_readFile :: String -> IO String prim_readFile external -- for internal implementation of readFile: prim_readFileContents :: String -> String prim_readFileContents external --- An action that writes a file. --- @param filename - The name of the file to be written. --- @param contents - The contents to be written to the file. writeFile :: String -> String -> IO () writeFile f s = (prim_writeFile $## f) s prim_writeFile :: String -> String -> IO () prim_writeFile external --- An action that appends a string to a file. --- It behaves like writeFile if the file does not exist. --- @param filename - The name of the file to be written. --- @param contents - The contents to be appended to the file. appendFile :: String -> String -> IO () appendFile f s = (prim_appendFile $## f) s prim_appendFile :: String -> String -> IO () prim_appendFile external --- Action to print a string on stdout. putStr :: String -> IO () putStr [] = done putStr (c:cs) = putChar c >> putStr cs --- Action to print a string with a newline on stdout. putStrLn :: String -> IO () putStrLn cs = putStr cs >> putChar '\n' --- Action to read a line from stdin. getLine :: IO String getLine = do c <- getChar if c=='\n' then return [] else do cs <- getLine return (c:cs) ---------------------------------------------------------------------------- -- Error handling in the I/O monad: --- The (abstract) type of error values. --- Currently, it distinguishes between general IO errors, --- user-generated errors (see 'userError'), failures and non-determinism --- errors during IO computations. These errors can be caught by 'catch' --- and shown by 'showError'. --- Each error contains a string shortly explaining the error. --- This type might be extended in the future to distinguish --- further error situations. data IOError = IOError String -- normal IO error | UserError String -- user-specified error | FailError String -- failing computation | NondetError String -- non-deterministic computation --- A user error value is created by providing a description of the --- error situation as a string. userError :: String -> IOError userError s = UserError s --- Raises an I/O exception with a given error value. ioError :: IOError -> IO _ ioError err = error (showError err) --- Shows an error values as a string. showError :: IOError -> String showError (IOError s) = "i/o error: " ++ s showError (UserError s) = "user error: " ++ s showError (FailError s) = "fail error: " ++ s showError (NondetError s) = "nondet error: " ++ s --- Catches a possible error or failure during the execution of an --- I/O action. `(catch act errfun)` executes the I/O action --- `act`. If an exception or failure occurs --- during this I/O action, the function `errfun` is applied --- to the error value. catch :: IO a -> (IOError -> IO a) -> IO a catch external ---------------------------------------------------------------------------- --- Converts an arbitrary term into an external string representation. show :: _ -> String show x = prim_show $## x prim_show :: _ -> String prim_show external --- Converts a term into a string and prints it. print :: _ -> IO () print t = putStrLn (show t) --- Solves a constraint as an I/O action. --- Note: the constraint should be always solvable in a deterministic way doSolve :: Bool -> IO () doSolve b | b = done -- IO monad auxiliary functions: --- Executes a sequence of I/O actions and collects all results in a list. sequenceIO :: [IO a] -> IO [a] sequenceIO [] = return [] sequenceIO (c:cs) = do x <- c xs <- sequenceIO cs return (x:xs) --- Executes a sequence of I/O actions and ignores the results. sequenceIO_ :: [IO _] -> IO () sequenceIO_ = foldr (>>) done --- Maps an I/O action function on a list of elements. --- The results of all I/O actions are collected in a list. mapIO :: (a -> IO b) -> [a] -> IO [b] mapIO f = sequenceIO . map f --- Maps an I/O action function on a list of elements. --- The results of all I/O actions are ignored. mapIO_ :: (a -> IO _) -> [a] -> IO () mapIO_ f = sequenceIO_ . map f --- Folds a list of elements using an binary I/O action and a value --- for the empty list. foldIO :: (a -> b -> IO a) -> a -> [b] -> IO a foldIO _ a [] = return a foldIO f a (x:xs) = f a x >>= \fax -> foldIO f fax xs --- Apply a pure function to the result of an I/O action. liftIO :: (a -> b) -> IO a -> IO b liftIO f m = m >>= return . f --- Like `mapIO`, but with flipped arguments. --- --- This can be useful if the definition of the function is longer --- than those of the list, like in --- --- forIO [1..10] $ \n -> do --- ... forIO :: [a] -> (a -> IO b) -> IO [b] forIO xs f = mapIO f xs --- Like `mapIO_`, but with flipped arguments. --- --- This can be useful if the definition of the function is longer --- than those of the list, like in --- --- forIO_ [1..10] $ \n -> do --- ... forIO_ :: [a] -> (a -> IO b) -> IO () forIO_ xs f = mapIO_ f xs --- Performs an `IO` action unless the condition is met. unless :: Bool -> IO () -> IO () unless p act = if p then done else act --- Performs an `IO` action when the condition is met. when :: Bool -> IO () -> IO () when p act = if p then act else done ---------------------------------------------------------------- -- Non-determinism and free variables: --- Non-deterministic choice _par excellence_. --- The value of `x ? y` is either `x` or `y`. --- @param x - The right argument. --- @param y - The left argument. --- @return either `x` or `y` non-deterministically. (?) :: a -> a -> a x ? _ = x _ ? y = y -- Returns non-deterministically any element of a list. anyOf :: [a] -> a anyOf = foldr1 (?) --- Evaluates to a fresh free variable. unknown :: _ unknown = let x free in x ---------------------------------------------------------------- --- Identity type synonym used to mark deterministic operations. type DET a = a --- Identity function used by the partial evaluator --- to mark expressions to be partially evaluated. PEVAL :: a -> a PEVAL x = x --- Evaluates the argument to normal form and returns it. normalForm :: a -> a normalForm x = id $!! x --- Evaluates the argument to ground normal form and returns it. --- Suspends as long as the normal form of the argument is not ground. groundNormalForm :: a -> a groundNormalForm x = id $## x -- Only for internal use: -- Representation of higher-order applications in FlatCurry. apply :: (a -> b) -> a -> b apply external -- Only for internal use: -- Representation of conditional rules in FlatCurry. cond :: Bool -> a -> a cond external -- Only for internal use: -- letrec ones (1:ones) -> bind ones to (1:ones) letrec :: a -> a -> Bool letrec external --- Non-strict equational constraint. Used to implement functional patterns. (=:<=) :: a -> a -> Bool (=:<=) external --- Non-strict equational constraint for linear functional patterns. --- Thus, it must be ensured that the first argument is always (after evalutation --- by narrowing) a linear pattern. Experimental. (=:<<=) :: a -> a -> Bool (=:<<=) external --- internal function to implement =:<= ifVar :: _ -> a -> a -> a ifVar external --- internal operation to implement failure reporting failure :: _ -> _ -> _ failure external -- the end of the standard prelude curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Prelude.prim_c2p000066400000000000000000000117001305333611600242640ustar00rootroot00000000000000 prim_standard prim_applySeq[raw] prim_standard prim_applyNormalForm[raw] prim_standard prim_applyNotFree[raw] prim_standard prim_applyGroundNormalForm[raw] prim_standard prim_Int_plus prim_standard prim_Int_minus prim_standard prim_Int_times prim_standard prim_Int_div prim_standard prim_Int_mod prim_standard prim_Int_quot prim_standard prim_Int_rem prim_standard prim_negateFloat prim_standard prim_seq[raw] prim_standard prim_ensureNotFree[raw] prim_standard prim_ord prim_standard prim_chr prim_readshowterm prim_showTerm prim_standard prim_error prim_standard prim_failed[raw] prim_standard boolEq[raw] prim_standard constrEq[raw] prim_standard unifEq[raw] prim_standard unifEqLinear[raw] prim_standard prim_ifVar[raw] prim_standard prim_concurrent_and[raw] prim_standard prim_apply[raw] prim_standard prim_cond[raw] prim_standard prim_letrec[raw] prim_standard prim_compare[raw] prim_standard prim_failure[raw] prim_standard prim_Monad_bind[raw] prim_standard prim_Monad_seq[raw] prim_standard prim_return[raw] prim_standard prim_putChar prim_standard prim_getChar prim_standard prim_readFile prim_standard prim_readFileContents[raw] prim_standard prim_writeFile[raw] prim_standard prim_appendFile[raw] prim_standard prim_catch[raw] curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Pretty.curry000066400000000000000000001562351305333611600236210ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library provides pretty printing combinators. --- The interface is that of --- [Daan Leijen's library](), (<+>), ($$), (<$+$>), (), (<$$>), (), (<$!$>), -- list combinators compose, hsep, vsep, vsepBlank, fillSep, sep, hcat, vcat, fillCat, cat, punctuate, encloseSep, encloseSepSpaced, hEncloseSep, fillEncloseSep, fillEncloseSepSpaced, list, listSpaced, set, setSpaced, tupled, tupledSpaced, semiBraces, semiBracesSpaced, -- bracketing combinators enclose, squotes, dquotes, bquotes, parens, parensIf, angles, braces, brackets, -- fillers fill, fillBreak, -- primitive type documents char, string, int, float, -- character documents lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket, squote, dquote, semi, colon, comma, space, dot, backslash, equals, larrow, rarrow, doubleArrow, doubleColon, bar, at, tilde, -- formatting combinators bold, faint, blinkSlow, blinkRapid, italic, underline, crossout, inverse, -- colorisation combinators black, red, green, yellow, blue, magenta, cyan, white, bgBlack, bgRed, bgGreen, bgYellow, bgBlue, bgMagenta, bgCyan, bgWhite ) where import qualified Dequeue as Q (Queue, cons, empty, matchHead, matchLast) infixl 5 $$, <$$>, , , <$!$>, <$+$> infixl 6 <>, <+> --- Standard printing with a column length of 80. pPrint :: Doc -> String pPrint = pretty 80 --- The abstract data type Doc represents pretty documents. data Doc = Doc (Tokens -> Tokens) --- Extract the internal representation from a document. deDoc :: Doc -> Tokens -> Tokens deDoc (Doc d) = d --- The empty document --- @return an empty document empty :: Doc empty = Doc Empty --- Is the document empty? isEmpty :: Doc -> Bool isEmpty (Doc d) = isEmptyText (d EOD) where isEmptyText t = case t of Empty EOD -> True _ -> False --- The document `(text s)` contains the literal string `s`. --- The string shouldn't contain any newline ('\n') characters. --- If the string contains newline characters, --- the function `string` should be used. --- @param s - a string without newline (`'\n'`) characters --- @return a document which contains the literal string text :: String -> Doc text s = Doc (Text s) --- The document `(linesep s)` advances to the next line and indents --- to the current nesting level. Document `(linesep s)` --- behaves like `(text s)` if the line break is undone by `group`. --- @param s - a string --- @return a document which advances to the next line or behaves --- like `(text s)` linesep :: String -> Doc linesep = Doc . LineBreak . Just --- The document `hardline` advances to the next line and indents --- to the current nesting level. `hardline` cannot be undone by `group`. --- @return a document which advances to the next line hardline :: Doc hardline = Doc (LineBreak Nothing) --- The document `line` advances to the next line and indents to the current --- nesting level. Document `line` behaves like `(text " ")` if the line break --- is undone by `group`. --- @return a document which advances to the next line or behaves --- like `(text " ")` line :: Doc line = linesep " " --- The document `linebreak` advances to the next line and indents to --- the current nesting level. Document `linebreak` behaves like `(text "")` --- if the line break is undone by `group`. --- @return a document which advances to the next line or behaves like --- `(text "")` linebreak :: Doc linebreak = linesep "" --- The document `softline` behaves like `space` if the resulting output --- fits the page, otherwise it behaves like `line`. --- `softline = group line` --- @return a document which behaves like `space` or `line` softline :: Doc softline = group line --- The document `softbreak` behaves like `(text "")` if the resulting output --- fits the page, otherwise it behaves like `line`. --- `softbreak = group linebreak` --- @return a document which behaves like `(text "")` or `line` softbreak :: Doc softbreak = group linebreak --- The combinator `group` is used to specify alternative layouts. --- The document `(group x)` undoes all line breaks in document `x`. --- The resulting line is added to the current line if that fits the page. --- Otherwise, the document `x` is rendered without any changes. --- @param d - a document --- @return document d without line breaks if that fits the page. group :: Doc -> Doc group d = Doc (OpenGroup . deDoc d . CloseGroup) --- The document `(nest i d)` renders document `d` with the current --- indentation level increased by `i` (See also `hang`, --- `align` and `indent`). --- --- nest 2 (text "hello" $$ text "world") $$ text "!" --- --- outputs as: --- --- hello --- world --- ! --- --- @param i - an integer which increases the indentation level --- @param d - a document --- @return document d with an indentation level increased by i nest :: Int -> Doc -> Doc nest i d = Doc (OpenNest (Inc i) . deDoc d . CloseNest) --- The combinator `hang` implements hanging indentation. --- The document `(hang i d)` renders document `d` with a nesting level set --- to the current column plus `i`. The following example uses hanging --- indentation for some text: --- --- test = hang 4 --- (fillSep --- (map text --- (words "the hang combinator indents these words !"))) --- --- Which lays out on a page with a width of 20 characters as: --- --- the hang combinator --- indents these --- words ! --- --- The hang combinator is implemented as: --- --- hang i x = align (nest i x) --- --- @param i - an integer which increases the indentation level --- @param d - a document --- @return document d with an indentation level set to the current column plus i hang :: Int -> Doc -> Doc hang i x = align (nest i x) --- The document `(align d)` renders document `d with the nesting level --- set to the current column. It is used for example to implement `hang`. --- --- As an example, we will put a document right above another one, --- regardless of the current nesting level: --- --- x $$ y = align (x $$ y) --- test = text "hi" <+> (text "nice" $$ text "world") --- --- which will be layed out as: --- --- hi nice --- world --- --- @param d - a document --- @return document d with the nesting level set to the current column align :: Doc -> Doc align d = Doc (OpenNest Align . deDoc d . CloseNest) --- The document `(indent i d)` indents document `d` with `i` spaces. --- --- test = indent 4 (fillSep (map text --- (words "the indent combinator indents these words !"))) --- --- Which lays out with a page width of 20 as: --- --- the indent --- combinator --- indents these --- words ! --- --- @param i - an integer which increases the indentation level --- @param d - a document --- @return document d with an indentation level set to the current column --- plus i indent :: Int -> Doc -> Doc indent i d = hang i (spaces i <> d) --- The document `(combine c d1 d2)` combines document `d1` and `d2` with --- document `c` in between using `(<>)` with identity `empty`. --- Thus, the following equations hold. --- --- combine c d1 empty == d1 --- combine c empty d2 == d2 --- combine c d1 d2 == d1 <> c <> d2 if neither d1 nor d2 are empty --- --- @param c - the middle document --- @param d1 - the left document --- @param d2 - the right document --- @return concatenation of d1 and d2 with c in between unless one --- of the documents is empty combine :: Doc -> Doc -> Doc -> Doc combine c d1 d2 | isEmpty d1 = d2 | isEmpty d2 = d1 | otherwise = enclose d1 d2 c --- The document `(x <> y)` concatenates document `x` and document `y`. --- It is an associative operation having `empty` as a left and right unit. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y without seperator with identity empty (<>) :: Doc -> Doc -> Doc d1 <> d2 | isEmpty d1 = d2 | isEmpty d2 = d1 | otherwise = Doc (deDoc d1 . deDoc d2) --- The document `(x <+> y)` concatenates document `x` and `y` with a --- `space` in between with identity `empty`. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y with a space in between (<+>) :: Doc -> Doc -> Doc (<+>) = combine space --- The document `(x $$ y)` concatenates document x and y with a --- `line` in between with identity `empty`. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y with a line in between ($$) :: Doc -> Doc -> Doc ($$) = combine line --- The document `(x <$+$> y)` concatenates document `x` and `y` with a --- blank line in between with identity `empty`. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y with a blank line in between (<$+$>) :: Doc -> Doc -> Doc (<$+$>) = combine (line <> linebreak) --- The document `(x y)` concatenates document `x` and `y` with --- a `softline` in between with identity `empty`. --- This effectively puts `x` and `y` either next to each other --- (with a `space` in between) or underneath each other. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y with a softline in between () :: Doc -> Doc -> Doc () = combine softline --- The document `(x <$$> y)` concatenates document `x` and `y` with a --- `linebreak` in between with identity `empty`. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y with a linebreak in between (<$$>) :: Doc -> Doc -> Doc (<$$>) = combine linebreak --- The document `(x y)` concatenates document `x` and `y` with a --- `softbreak` in between with identity `empty`. --- This effectively puts `x` and `y` either right next to each other --- or underneath each other. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y with a softbreak in between () :: Doc -> Doc -> Doc () = combine softbreak --- The document `(x <$!$> y)` concatenates document `x` and `y` with a --- `hardline` in between with identity `empty`. --- This effectively puts `x` and `y` underneath each other. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y with a hardline in between (<$!$>) :: Doc -> Doc -> Doc (<$!$>) = combine hardline --- The document `(compose f xs)` concatenates all documents `xs` --- with function `f`. --- Function `f` should be like `(<+>)`, `($$)` and so on. --- @param f - a combiner function --- @param xs - a list of documents --- @return concatenation of documents compose :: (Doc -> Doc -> Doc) -> [Doc] -> Doc compose _ [] = empty compose op ds@(_:_) = foldr1 op ds -- no seperator at the end --- The document `(hsep xs)` concatenates all documents `xs` --- horizontally with `(<+>)`. --- @param xs - a list of documents --- @return horizontal concatenation of documents hsep :: [Doc] -> Doc hsep = compose (<+>) --- The document `(vsep xs)` concatenates all documents `xs` vertically with --- `($$)`. If a group undoes the line breaks inserted by `vsep`, --- all documents are separated with a `space`. --- --- someText = map text (words ("text to lay out")) --- test = text "some" <+> vsep someText --- --- This is layed out as: --- --- some text --- to --- lay --- out --- --- The `align` combinator can be used to align the documents --- under their first element: --- --- test = text "some" <+> align (vsep someText) --- --- This is printed as: --- --- some text --- to --- lay --- out --- --- @param xs - a list of documents --- @return vertical concatenation of documents vsep :: [Doc] -> Doc vsep = compose ($$) --- The document `vsep xs` concatenates all documents `xs` vertically with --- `(<$+$>)`. If a group undoes the line breaks inserted by `vsepBlank`, --- all documents are separated with a `space`. --- @param xs - a list of documents --- @return vertical concatenation of documents vsepBlank :: [Doc] -> Doc vsepBlank = compose (<$+$>) --- The document `(fillSep xs)` concatenates documents `xs` horizontally with --- `()` as long as its fits the page, than inserts a --- `line` and continues doing that for all documents in `xs`. --- `fillSep xs = foldr () empty xs` --- @param xs - a list of documents --- @return horizontal concatenation of documents fillSep :: [Doc] -> Doc fillSep = compose () --- The document `(sep xs)` concatenates all documents `xs` either horizontally --- with `(<+>)`, if it fits the page, or vertically --- with `($$)`. --- `sep xs = group (vsep xs)` --- @param xs - a list of documents --- @return horizontal concatenation of documents, if it fits the page, --- or vertical concatenation else sep :: [Doc] -> Doc sep = group . vsep --- The document `(hcat xs)` concatenates all documents `xs` horizontally --- with `(<>)`. --- @param xs - a list of documents --- @return horizontal concatenation of documents hcat :: [Doc] -> Doc hcat = compose (<>) --- The document `(vcat xs)` concatenates all documents `xs` vertically --- with `(<$$>)`. If a `group` undoes the line breaks inserted by `vcat`, --- all documents are directly concatenated. --- @param xs - a list of documents --- @return vertical concatenation of documents vcat :: [Doc] -> Doc vcat = compose (<$$>) --- The document `(fillCat xs)` concatenates documents `xs` horizontally --- with `()` as long as its fits the page, than inserts a `linebreak` --- and continues doing that for all documents in `xs`. --- `fillCat xs = foldr () empty xs` --- @param xs - a list of documents --- @return horizontal concatenation of documents fillCat :: [Doc] -> Doc fillCat = compose () --- The document `(cat xs)` concatenates all documents `xs` either horizontally --- with `(<>)`, if it fits the page, or vertically with --- `(<$$>)`. --- `cat xs = group (vcat xs)` --- @param xs - a list of documents --- @return horizontal concatenation of documents cat :: [Doc] -> Doc cat = group . vcat --- `(punctuate p xs)` concatenates all documents `xs` with document `p` except --- for the last document. --- --- someText = map text ["words","in","a","tuple"] --- test = parens (align (cat (punctuate comma someText))) --- --- This is layed out on a page width of 20 as: --- --- (words,in,a,tuple) --- --- But when the page width is 15, it is layed out as: --- --- (words, --- in, --- a, --- tuple) --- --- (If you want put the commas in front of their elements instead of at the --- end, you should use `tupled` or, in general, `encloseSep`.) --- @param p - a document as seperator --- @param xs - a list of documents --- @return concatenation of documents with p in between punctuate :: Doc -> [Doc] -> [Doc] punctuate d ds = go ds where go [] = [] go [x] = [x] go (x:xs@(_:_)) = (x <> d) : go xs --- The document `(encloseSep l r s xs)` concatenates the documents `xs` --- seperated by `s` and encloses the resulting document by `l` and `r`. --- The documents are rendered horizontally if that fits the page. Otherwise --- they are aligned vertically. All seperators are put in front of the --- elements. --- --- For example, the combinator `list` can be defined with `encloseSep`: --- --- list xs = encloseSep lbracket rbracket comma xs --- test = text "list" <+> (list (map int [10,200,3000])) --- --- Which is layed out with a page width of 20 as: --- --- list [10,200,3000] --- --- But when the page width is 15, it is layed out as: --- --- list [10 --- ,200 --- ,3000] --- --- @param l - left document --- @param r - right document --- @param s - a document as seperator --- @param xs - a list of documents --- @return concatenation of l, xs (with s in between) and r encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc encloseSep l r _ [] = l <> r encloseSep l r s (d:ds) = align (enclose l r (cat (d : map (s <>) ds))) --- The document `(encloseSepSpaced l r s xs)` concatenates the documents `xs` --- seperated by `s` and encloses the resulting document by `l` and `r`. --- In addition, after each occurrence of `s`, after `l`, and before `r`, --- a `space` is inserted. --- The documents are rendered horizontally if that fits the page. Otherwise --- they are aligned vertically. All seperators are put in front of the --- elements. --- --- @param l - left document --- @param r - right document --- @param s - a document as seperator --- @param xs - a list of documents --- @return concatenation of l, xs (with s in between) and r encloseSepSpaced :: Doc -> Doc -> Doc -> [Doc] -> Doc encloseSepSpaced l r s = encloseSep (l <> space) (space <> r) (s <> space) --- The document `(hEncloseSep l r s xs)` concatenates the documents `xs` --- seperated by `s` and encloses the resulting document by `l` and `r`. --- --- The documents are rendered horizontally. --- @param l - left document --- @param r - right document --- @param s - a document as seperator --- @param xs - a list of documents --- @return concatenation of l, xs (with s in between) and r hEncloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc hEncloseSep l r _ [] = l <> r hEncloseSep l r s (d:ds) = align (enclose l r (hcat (d : map (s <>) ds))) --- The document `(fillEncloseSep l r s xs)` concatenates the documents `xs` --- seperated by `s` and encloses the resulting document by `l` and `r`. --- --- The documents are rendered horizontally if that fits the page. --- Otherwise they are aligned vertically. --- All seperators are put in front of the elements. --- @param l - left document --- @param r - right document --- @param s - a document as seperator --- @param xs - a list of documents --- @return concatenation of l, xs (with s in between) and r fillEncloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc fillEncloseSep l r _ [] = l <> r fillEncloseSep l r s (d:ds) = align (enclose l r (fillCat (d : map (s <>) ds))) --- The document `(fillEncloseSepSpaced l r s xs)` concatenates the documents --- `xs` seperated by `s` and encloses the resulting document by `l` and `r`. --- In addition, after each occurrence of `s`, after `l`, and before `r`, --- a `space` is inserted. --- --- The documents are rendered horizontally if that fits the page. --- Otherwise, they are aligned vertically. --- All seperators are put in front of the elements. --- @param l - left document --- @param r - right document --- @param s - a document as seperator --- @param xs - a list of documents --- @return concatenation of l, xs (with s in between) and r fillEncloseSepSpaced :: Doc -> Doc -> Doc -> [Doc] -> Doc fillEncloseSepSpaced l r s = fillEncloseSep (l <> space) (space <> r) (s <> space) --- The document `(list xs)` comma seperates the documents `xs` and encloses --- them in square brackets. The documents are rendered horizontally if --- that fits the page. Otherwise they are aligned vertically. --- All comma seperators are put in front of the elements. --- @param xs - a list of documents --- @return comma seperated documents xs and enclosed in square brackets list :: [Doc] -> Doc list = encloseSep lbracket rbracket comma --- Spaced version of `list` listSpaced :: [Doc] -> Doc listSpaced = encloseSepSpaced lbracket rbracket comma --- The document `(set xs)` comma seperates the documents `xs` and encloses --- them in braces. The documents are rendered horizontally if --- that fits the page. Otherwise they are aligned vertically. --- All comma seperators are put in front of the elements. --- @param xs - a list of documents --- @return comma seperated documents xs and enclosed in braces set :: [Doc] -> Doc set = encloseSep lbrace rbrace comma --- Spaced version of `set` setSpaced :: [Doc] -> Doc setSpaced = encloseSepSpaced lbrace rbrace comma --- The document `(tupled xs)` comma seperates the documents `xs` and encloses --- them in parenthesis. The documents are rendered horizontally if that fits --- the page. Otherwise they are aligned vertically. --- All comma seperators are put in front of the elements. --- @param xs - a list of documents --- @return comma seperated documents xs and enclosed in parenthesis tupled :: [Doc] -> Doc tupled = encloseSep lparen rparen comma --- Spaced version of `tupled` tupledSpaced :: [Doc] -> Doc tupledSpaced = encloseSepSpaced lparen rparen comma --- The document `(semiBraces xs)` seperates the documents `xs` with semi colons --- and encloses them in braces. The documents are rendered horizontally --- if that fits the page. Otherwise they are aligned vertically. --- All semi colons are put in front of the elements. --- @param xs - a list of documents --- @return documents xs seperated with semi colons and enclosed in braces semiBraces :: [Doc] -> Doc semiBraces = encloseSep lbrace rbrace semi --- Spaced version of `semiBraces` semiBracesSpaced :: [Doc] -> Doc semiBracesSpaced = encloseSepSpaced lbrace rbrace semi --- The document `(enclose l r x)` encloses document `x` between --- documents `l` and `r` using `(<>)`. --- `enclose l r x = l <> x <> r` --- @param l - the left document --- @param r - the right document --- @param x - the middle document --- @return concatenation of l, x and r enclose :: Doc -> Doc -> Doc -> Doc enclose l r d = l <> d <> r --- Document `(squotes x)` encloses document `x` with single quotes `"'"`. --- @param x - a document --- @return document x enclosed by single quotes squotes :: Doc -> Doc squotes = enclose squote squote --- Document `(dquotes x)` encloses document `x` with double quotes. --- @param x - a document --- @return document x enclosed by double quotes dquotes :: Doc -> Doc dquotes = enclose dquote dquote --- Document `(bquotes x)` encloses document `x` with back quotes `"\`"`. --- @param x - a document --- @return document x enclosed by `\`` quotes bquotes :: Doc -> Doc bquotes = enclose bquote bquote --- Document `(parens x)` encloses document `x` in parenthesis, --- `"("` and `")"`. --- @param x - a document --- @return document x enclosed in parenthesis parens :: Doc -> Doc parens = enclose lparen rparen --- Document `(parensIf x)` encloses document `x` in parenthesis,`"("` and `")"`, --- iff the condition is true. --- @param x - a document --- @return document x enclosed in parenthesis iff the condition is true parensIf :: Bool -> Doc -> Doc parensIf b s = if b then parens s else s --- Document `(angles x)` encloses document `x` in angles, `"<"` and `">"`. --- @param x - a document --- @return document x enclosed in angles angles :: Doc -> Doc angles = enclose langle rangle --- Document `(braces x)` encloses document `x` in braces, `"{"` and `"}"`. --- @param x - a document --- @return document x enclosed in braces braces :: Doc -> Doc braces = enclose lbrace rbrace --- Document `(brackets x)` encloses document `x` in square brackets, --- `"["` and `"]"`. --- @param x - a document --- @return document x enclosed in square brackets brackets :: Doc -> Doc brackets = enclose lbracket rbracket --- The document `(char c)` contains the literal character `c`. --- The character should not be a newline (`\n`), --- the function `line` should be used for line breaks. --- @param c - a character (not `\n`) --- @return a document which contains the literal character c char :: Char -> Doc char c = text [c] --- The document `(string s)` concatenates all characters in `s` using --- `line` for newline characters and `char` for all other characters. --- It is used instead of `text` whenever the text contains newline characters. --- @param s - a string --- @return a document which contains the string s string :: String -> Doc string = hcat . map (\c -> if elem c ['\n','\r'] then line else char c) --- The document `(int i)` shows the literal integer `i` using `text`. --- @param i - an integer --- @return a document which contains the integer i int :: Int -> Doc int n = text (show n) --- The document `(float f)` shows the literal float `f` using `text`. --- @param f - a float --- @return a document which contains the float f float :: Float -> Doc float x = text (show x) --- The document `lparen` contains a left parenthesis, `"("`. --- @return a document which contains a left parenthesis lparen :: Doc lparen = char '(' --- The document `rparen` contains a right parenthesis, `")"`. --- @return a document which contains a right parenthesis rparen :: Doc rparen = char ')' --- The document `langle` contains a left angle, `"<"`. --- @return a document which contains a left angle langle :: Doc langle = char '<' --- The document `rangle` contains a right angle, `">"`. --- @return a document which contains a right angle rangle :: Doc rangle = char '>' --- The document `lbrace` contains a left brace, `"{"`. --- @return a document which contains a left brace lbrace :: Doc lbrace = char '{' --- The document `rbrace` contains a right brace, `"}"`. --- @return a document which contains a right brace rbrace :: Doc rbrace = char '}' --- The document `lbracket` contains a left square bracket, `"["`. --- @return a document which contains a left square bracket lbracket :: Doc lbracket = char '[' --- The document `rbracket` contains a right square bracket, `"]"`. --- @return a document which contains a right square bracket rbracket :: Doc rbracket = char ']' --- The document `squote` contains a single quote, `"'"`. --- @return a document which contains a single quote squote :: Doc squote = char '\'' --- The document `dquote` contains a double quote. --- @return a document which contains a double quote dquote :: Doc dquote = char '\"' --- The document `dquote` contains a `'`'` quote. --- @return a document which contains a `'`'` quote bquote :: Doc bquote = char '`' --- The document `semi` contains a semi colon, `";"`. --- @return a document which contains a semi colon semi :: Doc semi = char ';' --- The document `colon` contains a colon, `":"`. --- @return a document which contains a colon colon :: Doc colon = char ':' --- The document `comma` contains a comma, `","`. --- @return a document which contains a comma comma :: Doc comma = char ',' --- The document `space` contains a single space, `" "`. --- --- x <+> y = x <> space <> y --- --- @return a document which contains a single space space :: Doc space = char ' ' --- The document `(spaces n)` contains `n` spaces, when `n` is greater than 0. --- Otherwise the document is empty. --- --- @return a document which contains n spaces or the empty document, --- if n <= 0 spaces :: Int -> Doc spaces n | n <= 0 = empty | otherwise = text $ replicate n ' ' --- The document `dot` contains a single dot, `"."`. --- @return a document which contains a single dot dot :: Doc dot = char '.' --- The document `backslash` contains a back slash, `"\\"`. --- @return a document which contains a back slash backslash :: Doc backslash = char '\\' --- The document `equals` contains an equal sign, `"="`. --- @return a document which contains an equal equals :: Doc equals = char '=' --- The document `larrow` contains a left arrow sign, `"<-"`. --- @return a document which contains a left arrow sign larrow :: Doc larrow = text "<-" --- The document `rarrow` contains a right arrow sign, `"->"`. --- @return a document which contains a right arrow sign rarrow :: Doc rarrow = text "->" --- The document `doubleArrow` contains an double arrow sign, `"=>"`. --- @return a document which contains an double arrow sign doubleArrow :: Doc doubleArrow = text "=>" --- The document `doubleColon` contains a double colon sign, `"::"`. --- @return a document which contains a double colon sign doubleColon :: Doc doubleColon = text "::" --- The document `bar` contains a vertical bar sign, `"|"`. --- @return a document which contains a vertical bar sign bar :: Doc bar = char '|' --- The document `at` contains an at sign, `"@"`. --- @return a document which contains an at sign at :: Doc at = char '@' --- The document `tilde` contains a tilde sign, `"~"`. --- @return a document which contains a tilde sign tilde :: Doc tilde = char '~' --- The document `(fill i d)` renders document `d`. It than appends --- `space`s until the width is equal to `i`. If the width of `d` is --- already larger, nothing is appended. This combinator is quite --- useful in practice to output a list of bindings. The following --- example demonstrates this. --- --- types = [("empty","Doc") --- ,("nest","Int -> Doc -> Doc") --- ,("linebreak","Doc")] --- --- ptype (name,tp) --- = fill 6 (text name) <+> text "::" <+> text tp --- --- test = text "let" <+> align (vcat (map ptype types)) --- --- Which is layed out as: --- --- let empty :: Doc --- nest :: Int -> Doc -> Doc --- linebreak :: Doc --- --- Note that `fill` is not guaranteed to be linear-time bounded since it has to --- compute the width of a document before pretty printing it fill :: Int -> Doc -> Doc fill i d = d <> fill' where w = width d fill' = if w >= i then empty else spaces (i - w) --- The document `(fillBreak i d)` first renders document `d`. It --- than appends `space`s until the width is equal to `i`. If the --- width of `d` is already larger than `i`, the nesting level is --- increased by `i` and a `line` is appended. When we redefine `ptype` --- in the previous example to use `fillBreak`, we get a useful --- variation of the previous output: --- --- ptype (name,tp) --- = fillBreak 6 (text name) <+> text "::" <+> text tp --- --- The output will now be: --- --- let empty :: Doc --- nest :: Int -> Doc -> Doc --- linebreak --- :: Doc --- --- Note that `fillBreak` is not guaranteed to be linear-time bounded since it --- has to compute the width of a document before pretty printing it fillBreak :: Int -> Doc -> Doc fillBreak i d = d <> fill' where w = width d fill' = if w >= i then nest i linebreak else spaces (i - w) --- Compute the width of a given document width :: Doc -> Int width (Doc d) = width' 0 (d EOD) where width' w EOD = w width' w (Empty ts) = width' w ts width' w (Text s ts) = width' (w + length s) ts width' w (LineBreak Nothing ts) = width' w ts width' w (LineBreak (Just s) ts) = width' (w + length s) ts width' w (OpenGroup ts) = width' w ts width' w (CloseGroup ts) = width' w ts width' w (OpenNest _ ts) = width' w ts width' w (CloseNest ts) = width' w ts width' w (OpenFormat _ ts) = width' w ts width' w (CloseFormat ts) = width' w ts -- ----------------------------------------------------------------------------- -- Formatting combinators -- ----------------------------------------------------------------------------- --- The document `(bold d)` displays document `d` with bold text --- @param d - a document --- @return document d displayed with bold text bold :: Doc -> Doc bold d = Doc (OpenFormat (SetIntensity Bold) . deDoc d . CloseFormat) --- The document `(faint d)` displays document `d` with faint text --- @param d - a document --- @return document d displayed with faint text faint :: Doc -> Doc faint d = Doc (OpenFormat (SetIntensity Faint) . deDoc d . CloseFormat) --- The document `(blinkSlow d)` displays document `d` with slowly blinking text --- (rarely supported) --- @param d - a document --- @return document d displayed with slowly blinking text blinkSlow :: Doc -> Doc blinkSlow d = Doc (OpenFormat (SetBlinkMode Slow) . deDoc d . CloseFormat) --- The document `(blinkRapid d)` displays document `d` with rapidly blinking --- text (rarely supported) --- @param d - a document --- @return document d displayed with rapidly blinking text blinkRapid :: Doc -> Doc blinkRapid d = Doc (OpenFormat (SetBlinkMode Rapid) . deDoc d . CloseFormat) --- The document `(italic d)` displays document `d` with italicized text --- (rarely supported) --- @param d - a document --- @return document d displayed with italicized text italic :: Doc -> Doc italic d = Doc (OpenFormat (SetItalicized True) . deDoc d . CloseFormat) --- The document `(underline d)` displays document `d` with underlined text --- @param d - a document --- @return document d displayed with underlined text underline :: Doc -> Doc underline d = Doc (OpenFormat (SetUnderlined True) . deDoc d . CloseFormat) --- The document `(crossout d)` displays document `d` with crossed out text --- @param d - a document --- @return document d displayed with crossed out text crossout :: Doc -> Doc crossout d = Doc (OpenFormat (SetCrossedout True) . deDoc d . CloseFormat) --- The document `(inverse d)` displays document `d` with inversed coloring, --- i.e. use text color of `d` as background color and background color of `d` --- as text color --- @param d - a document --- @return document d displayed with inversed coloring inverse :: Doc -> Doc inverse d = Doc (OpenFormat (InverseColoring True) . deDoc d . CloseFormat) -- ----------------------------------------------------------------------------- -- Colorisation combinators -- ----------------------------------------------------------------------------- -- foreground colors --- The document `(black d)` displays document `d` with black text color --- @param d - a document --- @return document d displayed with black text color black :: Doc -> Doc black d = Doc (OpenFormat (SetForeground Black) . deDoc d . CloseFormat) --- The document `(red d)` displays document `d` with red text color --- @param d - a document --- @return document d displayed with red text color red :: Doc -> Doc red d = Doc (OpenFormat (SetForeground Red) . deDoc d . CloseFormat) --- The document `(green d)` displays document `d` with green text color --- @param d - a document --- @return document d displayed with green text color green :: Doc -> Doc green d = Doc (OpenFormat (SetForeground Green) . deDoc d . CloseFormat) --- The document `(yellow d)` displays document `d` with yellow text color --- @param d - a document --- @return document d displayed with yellow text color yellow :: Doc -> Doc yellow d = Doc (OpenFormat (SetForeground Yellow) . deDoc d . CloseFormat) --- The document `(blue d)` displays document `d` with blue text color --- @param d - a document --- @return document d displayed with blue text color blue :: Doc -> Doc blue d = Doc (OpenFormat (SetForeground Blue) . deDoc d . CloseFormat) --- The document `(magenta d)` displays document `d` with magenta text color --- @param d - a document --- @return document d displayed with magenta text color magenta :: Doc -> Doc magenta d = Doc (OpenFormat (SetForeground Magenta) . deDoc d . CloseFormat) --- The document `(cyan d)` displays document `d` with cyan text color --- @param d - a document --- @return document d displayed with cyan text color cyan :: Doc -> Doc cyan d = Doc (OpenFormat (SetForeground Cyan) . deDoc d . CloseFormat) --- The document `(white d)` displays document `d` with white text color --- @param d - a document --- @return document d displayed with white text color white :: Doc -> Doc white d = Doc (OpenFormat (SetForeground White) . deDoc d . CloseFormat) -- background colors --- The document `(bgBlack d)` displays document `d` with black background color --- @param d - a document --- @return document d displayed with black background color bgBlack :: Doc -> Doc bgBlack d = Doc (OpenFormat (SetBackground Black) . deDoc d . CloseFormat) --- The document `(bgRed d)` displays document `d` with red background color --- @param d - a document --- @return document d displayed with red background color bgRed :: Doc -> Doc bgRed d = Doc (OpenFormat (SetBackground Red) . deDoc d . CloseFormat) --- The document `(bgGreen d)` displays document `d` with green background color --- @param d - a document --- @return document d displayed with green background color bgGreen :: Doc -> Doc bgGreen d = Doc (OpenFormat (SetBackground Green) . deDoc d . CloseFormat) --- The document `(bgYellow d)` displays document `d` with yellow background --- color --- @param d - a document --- @return document d displayed with yellow background color bgYellow :: Doc -> Doc bgYellow d = Doc (OpenFormat (SetBackground Yellow) . deDoc d . CloseFormat) --- The document `(bgBlue d)` displays document `d` with blue background color --- @param d - a document --- @return document d displayed with blue background color bgBlue :: Doc -> Doc bgBlue d = Doc (OpenFormat (SetBackground Blue) . deDoc d . CloseFormat) --- The document `(bgMagenta d)` displays document `d` with magenta background --- color --- @param d - a document --- @return document d displayed with magenta background color bgMagenta :: Doc -> Doc bgMagenta d = Doc (OpenFormat (SetBackground Magenta) . deDoc d . CloseFormat) --- The document `(bgCyan d)` displays document `d` with cyan background color --- @param d - a document --- @return document d displayed with cyan background color bgCyan :: Doc -> Doc bgCyan d = Doc (OpenFormat (SetBackground Cyan) . deDoc d . CloseFormat) --- The document `(bgWhite d)` displays document `d` with white background color --- @param d - a document --- @return document d displayed with white background color bgWhite :: Doc -> Doc bgWhite d = Doc (OpenFormat (SetBackground White) . deDoc d . CloseFormat) -- ----------------------------------------------------------------------------- -- Implementation -- ----------------------------------------------------------------------------- type Horizontal = Bool type Remaining = Int type Width = Int type Position = Int type StartPosition = Position type EndPosition = Position type Out = Remaining -> Margins -> FormatHistory -> String -- Type of a `group output function`: Takes information whether group content -- should be formatted horizontally or vertically and a continuation to output -- parts of the document which come after the group type OutGroupPrefix = Horizontal -> Out -> Out type Margins = [Int] -- A nesting is either an alignment or a relative indentation data Nesting = Align | Inc Int -- text colorisation data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White | Default -- console intensity data Intensity = Faint | Normal | Bold -- support of blinking text data BlinkMode = Off | Slow | Rapid -- text formatting statement data FormatStm = SetForeground Color | SetBackground Color | SetIntensity Intensity | SetBlinkMode BlinkMode | SetItalicized Bool | SetUnderlined Bool | SetCrossedout Bool | InverseColoring Bool type FormatHistory = [FormatStm] resetFormat :: FormatHistory -> (FormatStm, FormatHistory) resetFormat [] = error "Pretty.resetFormat2: illegal format history" resetFormat (stm:stms) = case stm of SetForeground _ -> (SetForeground (prevFGColor stms), stms) SetBackground _ -> (SetBackground (prevBGColor stms), stms) SetIntensity _ -> (SetIntensity (prevIntensity stms), stms) SetBlinkMode _ -> (SetBlinkMode (prevBlinkMode stms), stms) SetItalicized b -> (SetItalicized (not b), stms) SetUnderlined b -> (SetUnderlined (not b), stms) SetCrossedout b -> (SetCrossedout (not b), stms) InverseColoring b -> (InverseColoring (not b), stms) -- Find previous foreground color in history prevFGColor :: FormatHistory -> Color prevFGColor history = case history of [] -> Default (SetForeground c : _ ) -> c (_ : hs) -> prevFGColor hs -- Find previous background color in history prevBGColor :: FormatHistory -> Color prevBGColor history = case history of [] -> Default (SetBackground c : _ ) -> c (_ : hs) -> prevBGColor hs -- Find previous text intensity in history prevIntensity :: FormatHistory -> Intensity prevIntensity history = case history of [] -> Normal (SetIntensity i : _ ) -> i (_ : hs) -> prevIntensity hs -- Find previous blinking mode in history prevBlinkMode :: FormatHistory -> BlinkMode prevBlinkMode history = case history of [] -> Off (SetBlinkMode b : _ ) -> b (_ : hs) -> prevBlinkMode hs applyFormat :: FormatStm -> String applyFormat (SetForeground c) = txtMode (colorMode c) applyFormat (SetBackground c) = txtMode (colorMode c + 10) applyFormat (SetIntensity i) = txtMode (intensityMode i) applyFormat (SetBlinkMode b) = txtMode (blinkMode b) applyFormat (SetItalicized b) = txtMode (if b then 3 else 23) applyFormat (SetUnderlined b) = txtMode (if b then 4 else 24) applyFormat (SetCrossedout b) = txtMode (if b then 9 else 29) applyFormat (InverseColoring b) = txtMode (if b then 7 else 27) -- Text mode txtMode :: Int -> String txtMode m = csiCmd ++ show m ++ "m" where csiCmd :: String csiCmd = '\ESC' : '[' : "" -- Color mode colorMode :: Color -> Int colorMode c = case c of Black -> 30 Red -> 31 Green -> 32 Yellow -> 33 Blue -> 34 Magenta -> 35 Cyan -> 36 White -> 37 Default -> 39 -- Intensity mode intensityMode :: Intensity -> Int intensityMode i = case i of Faint -> 2 Normal -> 22 Bold -> 1 -- Blink mode blinkMode :: BlinkMode -> Int blinkMode b = case b of Off -> 25 Slow -> 5 Rapid -> 6 -- Token sequence. Note that the data type linearizes a document so that -- a fragment is usually followed by a remaining document. data Tokens = EOD -- end of document | Empty Tokens -- empty document | Text String Tokens -- string | LineBreak (Maybe String) Tokens -- linebreak that will be replaced by the -- separator if the linebreak is undone | OpenGroup Tokens -- Beginning of a group | CloseGroup Tokens -- End of a group | OpenNest Nesting Tokens -- Beginning of a nesting | CloseNest Tokens -- End of a nesting | OpenFormat FormatStm Tokens -- Beginning of a formatting statement | CloseFormat Tokens -- End of a formatting statement applyNesting :: Nesting -> Width -> Remaining -> Margins -> Margins applyNesting Align w r ms = (w - r) : ms applyNesting (Inc i) _ _ ms = case ms of m:_ -> (m + i) : ms _ -> error "Pretty.applyNesting: empty margin list" unApplyNesting :: Margins -> Margins unApplyNesting [] = error "Pretty.unApplyNesting: empty margin list" unApplyNesting (_:ms) = ms addSpaces :: Int -> Tokens -> String addSpaces m ts = case ts of LineBreak _ _ -> "" EOD -> "" Empty ts' -> addSpaces m ts' OpenGroup ts' -> addSpaces m ts' CloseGroup ts' -> addSpaces m ts' OpenNest _ ts' -> addSpaces m ts' CloseNest ts' -> addSpaces m ts' OpenFormat _ ts' -> addSpaces m ts' CloseFormat ts' -> addSpaces m ts' Text _ _ -> replicate m ' ' -- Normalise a token sequence using the following rewriting rules: -- -- CloseGroup (Text s ts) => Text s (CloseGroup ts) -- OpenGroup (Text s ts) => Text s (OpenGroup ts) -- OpenGroup (CloseGroup ts) => ts -- -- Rewriting moves `Text` tokens in and out of groups. The set of `lines` -- "belonging" to each group, i.e., the set of layouts, is left unchanged. normalise :: Tokens -> Tokens normalise = go id where go co EOD = co EOD go co (Empty ts) = go co ts -- there should be no deferred opening brackets go co (OpenGroup ts) = go (co . open) ts go co (CloseGroup ts) = go (co . CloseGroup) ts go co (LineBreak ms ts) = (co . LineBreak ms . go id) ts go co (Text s ts) = Text s (go co ts) go co (OpenNest n ts) = OpenNest n (go co ts) go co (CloseNest ts) = CloseNest (go co ts) go co (OpenFormat f ts) = OpenFormat f (go co ts) go co (CloseFormat ts) = CloseFormat (go co ts) open t = case t of CloseGroup ts -> ts _ -> OpenGroup t -- Transform a document into a group-closed document by normalising its token -- sequence. -- A document is called group-closed, if between the end of every `group` and -- the next `text` document there is always a `line` document. doc2Tokens :: Doc -> Tokens doc2Tokens (Doc d) = normalise (d EOD) --- `(pretty w d)` pretty prints document `d` with a page width of `w` characters --- @param w - width of page --- @param d - a document --- @return pretty printed document pretty :: Width -> Doc -> String pretty w d = noGroup (doc2Tokens d) w 1 w [0] [] -- Compute number of visible ASCII characters length :: String -> Int length = Prelude.length . filter isVisible where isVisible c = ord c `notElem` ([5, 6, 7] ++ [16 .. 31]) -- Basic pretty printing algorithm: -- -- 1. Determine for each group in the document its width, i.e. the space it -- requires for printing if it was printed horizontally, all in one line. -- 2. Traverse document tree and keep track of remaining free space in current -- output line. -- At the start of a group compare remaining space with width of the group: -- If the width is smaller or equal, the group is formatted horizontally, -- otherwise vertically. -- Determine widths of all groups and produce actual layout by traversing token -- sequence a single time using continuations: -- At the start of each group construct a `group output function` which receives -- formate information and information about the remaining space at the -- beginning of the group. -- Since groups can be nested we don't want to update a width value for each -- surrounding group when processing a token. Instead we introduce an absolute -- measure of a token's position: The width of a group is the difference between -- the position of its `CloseGroup` token and the position of its `OpenGroup` token. -- When traversing the document only the `group output function` of the -- innermost group is extended. All the other `group output function`s are -- passed on unchanged. When we come across a `CloseGroup` token we merge the -- function for the innermost group with the function for the next inner group. -- noGroup is used when there is currently no deferred group noGroup :: Tokens -> Width -> Position -> Out noGroup EOD _ _ _ _ _ = "" -- should not occur: noGroup (Empty ts) w p r ms fs = noGroup ts w p r ms fs noGroup (Text t ts) w p r ms fs = t ++ noGroup ts w (p + l) (r - l) ms fs where l = length t noGroup (LineBreak _ ts) w p _ ms fs = case ms of [] -> error "Pretty.noGroup: illegal line" m:_ -> '\n' : addSpaces m ts ++ noGroup ts w (p + 1) (w - m) ms fs noGroup (OpenGroup ts) w p r ms fs = oneGroup ts w p (p + r) (\_ c -> c) r ms fs noGroup (CloseGroup ts) w p r ms fs = noGroup ts w p r ms fs -- may have been pruned noGroup (OpenNest n ts) w p r ms fs = noGroup ts w p r (applyNesting n w r ms) fs noGroup (CloseNest ts) w p r ms fs = noGroup ts w p r (unApplyNesting ms) fs noGroup (OpenFormat f ts) w p r ms fs = applyFormat f ++ noGroup ts w p r ms (f:fs) noGroup (CloseFormat ts) w p r ms fs = applyFormat f ++ noGroup ts w p r ms ofs where (f, ofs) = resetFormat fs -- oneGroup is used when there is one deferred group -- Whenever the tokens `Text` or `LineBreak` are processed, -- i.e. the current position is increased, -- pruneOne checks whether whether the group still fits the line -- Furthermore the `group output function` is extended with the current token oneGroup :: Tokens -> Width -> Position -> EndPosition -> OutGroupPrefix -> Out oneGroup EOD _ _ _ _ = error "Pretty.oneGroup: EOD" -- should not occur: oneGroup (Empty ts) w p e outGrpPre = oneGroup ts w p e outGrpPre oneGroup (Text s ts) w p e outGrpPre = pruneOne ts w (p + l) e (\h cont -> outGrpPre h (outText cont)) where l = length s outText cont r ms fs = s ++ cont (r - l) ms fs oneGroup (LineBreak Nothing ts) w p _ outGrpPre = outGrpPre False (outLine (noGroup ts w p)) where outLine _ _ [] _ = error "Pretty.oneGroup.outLine: empty margins" outLine cont _ ms@(m:_) fs = '\n' : addSpaces m ts ++ cont (w - m) ms fs oneGroup (LineBreak (Just s) ts) w p e outGrpPre = pruneOne ts w (p + l) e (\h cont -> outGrpPre h (outLine h cont)) where l = length s outLine _ _ _ [] _ = error "Pretty.oneGroup.outLine: empty margins" outLine h cont r ms@(m:_) fs = if h then s ++ cont (r - l) ms fs else '\n' : addSpaces m ts ++ cont (w - m) ms fs oneGroup (OpenGroup ts) w p e outGrpPre = multiGroup ts w p e outGrpPre Q.empty p (\_ cont -> cont) oneGroup (CloseGroup ts) w p e outGrpPre = outGrpPre (p <= e) (noGroup ts w p) oneGroup (OpenNest n ts) w p e outGrpPre = oneGroup ts w p e (\h cont -> outGrpPre h (\r ms fs -> cont r (applyNesting n w r ms) fs)) oneGroup (CloseNest ts) w p e outGrpPre = oneGroup ts w p e (\h cont -> outGrpPre h (\r ms fs -> cont r (unApplyNesting ms) fs)) oneGroup (OpenFormat f ts) w p e outGrpPre = oneGroup ts w p e (\h cont -> outGrpPre h (outFormat cont)) where outFormat cont r ms fs = applyFormat f ++ cont r ms (f:fs) oneGroup (CloseFormat ts) w p e outGrpPre = oneGroup ts w p e (\h cont -> outGrpPre h (outUnformat cont)) where outUnformat cont r ms fs = applyFormat f ++ cont r ms ofs where (f, ofs) = resetFormat fs -- multiGroup is used when there are at least two deferred groups -- Whenever the tokens `Text` or `LineBreak` are processed, i.e. the current position -- is increased, pruneMulti checks whether whether the outermost group still -- fits the line. -- Furthermore the `group output function` of the innermost group is extended -- with the current token. -- When we come across a `OpenGroup` token during traversal of the token sequence, -- the current innermost `group output function` is added to the queue. -- Reaching a `CloseGroup` token it is checked whether the queue still contains a -- deferred `group output function`: If the queue is empty, there is only one -- group left, otherwise there are at least two groups left. -- In both cases the function for the innermost group is merged with the -- function for the next inner group multiGroup :: Tokens -> Width -> Position -> EndPosition -> OutGroupPrefix -> Q.Queue (StartPosition, OutGroupPrefix) -> StartPosition -> OutGroupPrefix -> Out multiGroup EOD _ _ _ _ _ _ _ = error "Pretty.multiGroup: EOD" -- should not occur: multiGroup (Empty ts) w p e outGrpPreOuter qs s outGrpPreInner = multiGroup ts w p e outGrpPreOuter qs s outGrpPreInner multiGroup (Text t ts) w p e outGrpPreOuter qs s outGrpPreInner = pruneMulti ts w (p+l) e outGrpPreOuter qs s (\h cont -> outGrpPreInner h (outText cont)) where l = length t outText cont r ms fs = t ++ cont (r-l) ms fs multiGroup (LineBreak Nothing ts) w p _ outGrpPreOuter qs _ outGrpPreInner = pruneAll outGrpPreOuter qs where pruneAll outGrpPreOuter' qs' = outGrpPreOuter' False (\r -> (case Q.matchLast qs' of Nothing -> outGrpPreInner False (outLine (noGroup ts w p)) Just ((_,outGrpPre),qss) -> pruneAll outGrpPre qss) r) outLine _ _ [] _ = error "Pretty.oneGroup.outLine: empty margins" outLine cont _ ms@(m:_) fs = '\n' : addSpaces m ts ++ cont (w - m) ms fs multiGroup (LineBreak (Just s) ts) w p e outGrpPreOuter qs si outGrpPreInner = pruneMulti ts w (p + l) e outGrpPreOuter qs si (\h cont -> outGrpPreInner h (outLine h cont)) where l = length s outLine _ _ _ [] _ = error "Pretty.multiGroup.outLine: empty margins" outLine h cont r ms@(m:_) fs = if h then s ++ cont (r-l) ms fs else '\n': addSpaces m ts ++ cont (w-m) ms fs multiGroup (OpenGroup ts) w p e outGrpPreOuter qs si outGrpPreInner = multiGroup ts w p e outGrpPreOuter (Q.cons (si,outGrpPreInner) qs) p (\_ cont -> cont) multiGroup (CloseGroup ts) w p e outGrpPreOuter qs si outGrpPreInner = case Q.matchHead qs of Nothing -> oneGroup ts w p e (\h cont -> outGrpPreOuter h (\ri -> outGrpPreInner (p<=si+ri) cont ri)) Just ((s,outGrpPre),qs') -> multiGroup ts w p e outGrpPreOuter qs' s (\h cont -> outGrpPre h (\ri -> outGrpPreInner (p<=si+ri) cont ri)) multiGroup (OpenNest n ts) w p e outGrpPreOuter qs si outGrpPreInner = multiGroup ts w p e outGrpPreOuter qs si (\h cont -> outGrpPreInner h (\r ms fs -> cont r (applyNesting n w r ms) fs)) multiGroup (CloseNest ts) w p e outGrpPreOuter qs si outGrpPreInner = multiGroup ts w p e outGrpPreOuter qs si (\h cont -> outGrpPreInner h (\r ms fs -> cont r (unApplyNesting ms) fs)) multiGroup (OpenFormat f ts) w p e outGrpPreOuter qs si outGrpPreInner = multiGroup ts w p e outGrpPreOuter qs si (\h cont -> outGrpPreInner h (outFormat cont)) where outFormat cont r ms fs = applyFormat f ++ cont r ms (f:fs) multiGroup (CloseFormat ts) w p e outGrpPreOuter qs si outGrpPreInner = multiGroup ts w p e outGrpPreOuter qs si (\h cont -> outGrpPreInner h (outUnformat cont)) where outUnformat cont r ms fs = applyFormat f ++ cont r ms ofs where (f, ofs) = resetFormat fs -- pruneOne checks whether the outermost group (in this case there is only one -- group) still fits in the current line. If it doesn't fit, it applies the -- corresponding `group output function` (the group is formatted vertically) -- and continues processing the token sequence pruneOne :: Tokens -> Width -> Position -> EndPosition -> OutGroupPrefix -> Out pruneOne ts w p e outGrpPre | p <= e = oneGroup ts w p e outGrpPre | otherwise = outGrpPre False (noGroup ts w p) -- pruneMulti checks whether the outermost group (in this case there are at -- least two groups) still fits in the current line. If it doesn't fit, it -- applies the corresponding `group output function` (the last queue entry) and -- continues checking whether the next outermost group fits pruneMulti :: Tokens -> Width -> Position -> EndPosition -> OutGroupPrefix -> Q.Queue (StartPosition, OutGroupPrefix) -> StartPosition -> OutGroupPrefix -> Out pruneMulti ts w p e outGrpPreOuter qs si outGrpPreInner | p <= e = multiGroup ts w p e outGrpPreOuter qs si outGrpPreInner | otherwise = outGrpPreOuter False (\r -> (case Q.matchLast qs of Nothing -> pruneOne ts w p (si+r) outGrpPreInner Just ((s,outGrpPre),qs') -> pruneMulti ts w p (s+r) outGrpPre qs' si outGrpPreInner) r) -------------------------------------------------------------------------------- -- Debugging -------------------------------------------------------------------------------- -- inspect the token sequence of a document inspect :: Doc -> Tokens inspect (Doc d) = normalise (d EOD) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Profile.curry000066400000000000000000000112511305333611600237160ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Preliminary library to support profiling. --- --- @author Michael Hanus --- @version November 2015 --- @category general ------------------------------------------------------------------------------ module Profile(ProcessInfo(..), getProcessInfos, showMemInfo, printMemInfo, garbageCollectorOff, garbageCollectorOn, garbageCollect, profileTime, profileTimeNF, profileSpace, profileSpaceNF) where import List(intersperse) --- The data type for representing information about the state --- of a Curry process. --- @cons RunTime - the run time in milliseconds --- @cons ElapsedTime - the elapsed time in milliseconds --- @cons Memory - the total memory in bytes --- @cons Code - the size of the code area in bytes --- @cons Stack - the size of the local stack for recursive functions in bytes --- @cons Heap - the size of the heap to store term structures in bytes --- @cons Choices - the size of the choicepoint stack --- @cons GarbageCollections - the number of garbage collections performed data ProcessInfo = RunTime | ElapsedTime | Memory | Code | Stack | Heap | Choices | GarbageCollections --- Returns various informations about the current state of the Curry process. --- Note that the returned values are implementation dependent --- so that one should interpret them with care! --- --- Note for kics2 users: --- Since GHC version 7.x, one has to set the run-time option `-T` --- when this operation is used. This can be done by the kics2 command --- --- :set rts -T --- getProcessInfos :: IO [(ProcessInfo,Int)] getProcessInfos external --- Turns off the garbage collector of the run-time system (if possible). --- This could be useful to get more precise data of memory usage. garbageCollectorOff :: IO () garbageCollectorOff external --- Turns on the garbage collector of the run-time system (if possible). garbageCollectorOn :: IO () garbageCollectorOn external --- Invoke the garbage collector (if possible). --- This could be useful before run-time critical operations. garbageCollect :: IO () garbageCollect external --- Get a human readable version of the memory situation from the --- process infos. showMemInfo :: [(ProcessInfo,Int)] -> String showMemInfo infos = concat $ intersperse ", " $ formatItem Memory "Memory: " ++ formatItem Code "Code: " ++ formatItem Stack "Stack: " ++ formatItem Choices"Choices: " ++ formatItem Heap "Heap: " where formatItem i s = maybe [] (\v -> [s ++ showBytes v]) (lookup i infos) showBytes b = if b<10000 then show b else show (b `div` 1000) ++ " kb" --- Print a human readable version of the current memory situation --- of the Curry process. printMemInfo = getProcessInfos >>= putStrLn . showMemInfo --- Print the time needed to execute a given IO action. profileTime :: IO a -> IO a profileTime action = do garbageCollect pi1 <- getProcessInfos result <- action pi2 <- getProcessInfos putStrLn $ "Run time: " ++ (showInfoDiff pi1 pi2 RunTime) ++ " msec." putStrLn $ "Elapsed time: " ++ (showInfoDiff pi1 pi2 ElapsedTime) ++ " msec." putStrLn $ "Garbage collections: " ++ (showInfoDiff pi1 pi2 GarbageCollections) return result --- Evaluates the argument to normal form --- and print the time needed for this evaluation. profileTimeNF :: a -> IO () profileTimeNF exp = profileTime (seq (id $!! exp) done) --- Print the time and space needed to execute a given IO action. --- During the executation, the garbage collector is turned off to get the --- total space usage. profileSpace :: IO a -> IO a profileSpace action = do garbageCollect garbageCollectorOff pi1 <- getProcessInfos result <- action pi2 <- getProcessInfos garbageCollectorOn putStrLn $ "Run time: " ++ (showInfoDiff pi1 pi2 RunTime) ++ " msec." putStrLn $ "Elapsed time: " ++ (showInfoDiff pi1 pi2 ElapsedTime) ++ " msec." putStrLn $ "Garbage collections: " ++ (showInfoDiff pi1 pi2 GarbageCollections) putStrLn $ "Heap usage: " ++ (showInfoDiff pi1 pi2 Heap) ++ " bytes" putStrLn $ "Stack usage: " ++ (showInfoDiff pi1 pi2 Stack) ++ " bytes" return result --- Evaluates the argument to normal form --- and print the time and space needed for this evaluation. --- During the evaluation, the garbage collector is turned off to get the --- total space usage. profileSpaceNF :: a -> IO () profileSpaceNF exp = profileSpace (seq (id $!! exp) done) showInfoDiff infos1 infos2 item = show (maybe 0 id (lookup item infos2) - maybe 0 id (lookup item infos1)) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Profile.curry.pakcs000066400000000000000000000120741305333611600250220ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Preliminary library to support profiling. --- --- @author Michael Hanus --- @version December 2007 --- @category general ------------------------------------------------------------------------------ module Profile(ProcessInfo(..), getProcessInfos, showMemInfo, printMemInfo, garbageCollectorOff, garbageCollectorOn, garbageCollect, profileTime, profileTimeNF, profileSpace, profileSpaceNF, evalTime, evalSpace) where import List(intersperse) --- The data type for representing information about the state --- of a Curry process. --- @cons RunTime - the run time in milliseconds --- @cons ElapsedTime - the elapsed time in milliseconds --- @cons Memory - the total memory in bytes --- @cons Code - the size of the code area in bytes --- @cons Stack - the size of the local stack for recursive functions in bytes --- @cons Heap - the size of the heap to store term structures in bytes --- @cons Choices - the size of the choicepoint stack --- @cons GarbageCollections - the number of garbage collections performed data ProcessInfo = RunTime | ElapsedTime | Memory | Code | Stack | Heap | Choices | GarbageCollections --- Returns various informations about the current state of the Curry process. --- Note that the returned values are very implementation dependent --- so that one should interpret them with care! getProcessInfos :: IO [(ProcessInfo,Int)] getProcessInfos external --- Turns off the garbage collector of the run-time system (if possible). --- This could be useful to get more precise data of memory usage. garbageCollectorOff :: IO () garbageCollectorOff external --- Turns on the garbage collector of the run-time system (if possible). garbageCollectorOn :: IO () garbageCollectorOn external --- Invoke the garbage collector (if possible). --- This could be useful before run-time critical operations. garbageCollect :: IO () garbageCollect external --- Get a human readable version of the memory situation from the --- process infos. showMemInfo :: [(ProcessInfo,Int)] -> String showMemInfo infos = concat $ intersperse ", " $ formatItem Memory "Memory: " ++ formatItem Code "Code: " ++ formatItem Stack "Stack: " ++ formatItem Choices"Choices: " ++ formatItem Heap "Heap: " where formatItem i s = maybe [] (\v -> [s ++ showBytes v]) (lookup i infos) showBytes b = if b<10000 then show b else show (b `div` 1000) ++ " kb" --- Print a human readable version of the current memory situation --- of the Curry process. printMemInfo = getProcessInfos >>= putStrLn . showMemInfo --- Print the time needed to execute a given IO action. profileTime :: IO a -> IO a profileTime action = do garbageCollect pi1 <- getProcessInfos result <- action pi2 <- getProcessInfos putStrLn $ "Run time: " ++ (showInfoDiff pi1 pi2 RunTime) ++ " msec." putStrLn $ "Elapsed time: " ++ (showInfoDiff pi1 pi2 ElapsedTime) ++ " msec." putStrLn $ "Garbage collections: " ++ (showInfoDiff pi1 pi2 GarbageCollections) return result --- Evaluates the argument to normal form --- and print the time needed for this evaluation. profileTimeNF :: a -> IO () profileTimeNF exp = profileTime (seq (id $!! exp) done) --- Print the time and space needed to execute a given IO action. --- During the executation, the garbage collector is turned off to get the --- total space usage. profileSpace :: IO a -> IO a profileSpace action = do garbageCollect garbageCollectorOff pi1 <- getProcessInfos result <- action pi2 <- getProcessInfos garbageCollectorOn putStrLn $ "Run time: " ++ (showInfoDiff pi1 pi2 RunTime) ++ " msec." putStrLn $ "Elapsed time: " ++ (showInfoDiff pi1 pi2 ElapsedTime) ++ " msec." putStrLn $ "Garbage collections: " ++ (showInfoDiff pi1 pi2 GarbageCollections) putStrLn $ "Heap usage: " ++ (showInfoDiff pi1 pi2 Heap) ++ " bytes" putStrLn $ "Stack usage: " ++ (showInfoDiff pi1 pi2 Stack) ++ " bytes" return result --- Evaluates the argument to normal form --- and print the time and space needed for this evaluation. --- During the evaluation, the garbage collector is turned off to get the --- total space usage. profileSpaceNF :: a -> IO () profileSpaceNF exp = profileSpace (seq (id $!! exp) done) showInfoDiff infos1 infos2 item = show (maybe 0 id (lookup item infos2) - maybe 0 id (lookup item infos1)) --- Evaluates the argument to normal form (and return the normal form) --- and print the time needed for this evaluation on standard error. --- Included for backward compatibility only, use profileTime! evalTime :: a -> a evalTime external --- Evaluates the argument to normal form (and return the normal form) --- and print the time and space needed for this evaluation on standard error. --- During the evaluation, the garbage collector is turned off. --- Included for backward compatibility only, use profileSpace! evalSpace :: a -> a evalSpace external curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Profile.prim_c2p000066400000000000000000000016541305333611600242730ustar00rootroot00000000000000 prim_profile prim_getProcessInfos prim_profile prim_garbageCollectorOn prim_profile prim_garbageCollectorOff prim_profile prim_garbageCollect prim_profile prim_evalTime[raw] prim_profile prim_evalSpace[raw] curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Prolog.curry000066400000000000000000000150171305333611600235640ustar00rootroot00000000000000------------------------------------------------------------------------------ --- A library defining a representation for Prolog programs together --- with a simple pretty printer. --- It does not cover all aspects of Prolog but might be useful --- for applications generating Prolog programs. --- --- @author Michael Hanus --- @version May 2016 --- @category general ------------------------------------------------------------------------------ {-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-} module Prolog(PlClause(..), PlGoal(..), PlTerm(..), plList, showPlProg, showPlClause, showPlGoals, showPlGoal, showPlTerm) where import Char(isAlphaNum,isLower) import List(union,intercalate) ---------------------------------------------------------------------------- -- Representation of Prolog programs: --- A Prolog clause is either a program clause consisting of a head --- and a body, or a directive or a query without a head. data PlClause = PlClause String [PlTerm] [PlGoal] | PlDirective [PlGoal] | PlQuery [PlGoal] --- A Prolog goal is a literal, a negated goal, or a conditional. data PlGoal = PlLit String [PlTerm] | PlNeg [PlGoal] | PlCond [PlGoal] [PlGoal] [PlGoal] --- A Prolog term is a variable, atom, number, or structure. data PlTerm = PlVar String | PlAtom String | PlInt Int | PlFloat Float | PlStruct String [PlTerm] --- A Prolog list of Prolog terms. plList :: [PlTerm] -> PlTerm plList = foldr (\t ts -> PlStruct "." [t,ts]) (PlAtom "[]") ---------------------------------------------------------------------------- --- Shows a Prolog program in standard Prolog syntax. showPlProg :: [PlClause] -> String showPlProg clauses = unlines $ map (showPlClause . optimizeClause) clauses showPlClause :: PlClause -> String showPlClause (PlClause pred args []) = showPlGoal (PlLit pred args) ++ "." showPlClause (PlClause pred args body@(_:_)) = showPlGoal (PlLit pred args) ++ " :- " ++ showPlGoals body ++ "." showPlClause (PlDirective body) = ":- " ++ showPlGoals body ++ "." showPlClause (PlQuery body) = "?- " ++ showPlGoals body ++ "." showPlGoals :: [PlGoal] -> String showPlGoals gs = intercalate ", " (map showPlGoal gs) showPrimPlGoals :: [PlGoal] -> String showPrimPlGoals [] = "true" showPrimPlGoals [g] = showPlGoal g showPrimPlGoals gs@(_:_:_) = "(" ++ intercalate ", " (map showPlGoal gs) ++ ")" showPlGoal :: PlGoal -> String showPlGoal (PlLit pred args) = if pred=="=" then showPlTerm (args!!0) ++ "=" ++ showPlTerm (args!!1) else showPlTerm (PlStruct pred args) showPlGoal (PlNeg goal) = "\\+" ++ showPrimPlGoals goal showPlGoal (PlCond cond tgoal fgoal) = "(" ++ showPrimPlGoals cond ++ " -> " ++ showPlGoals tgoal ++ " ; " ++ showPlGoals fgoal ++ ")" showPlTerm :: PlTerm -> String showPlTerm (PlVar v) = v showPlTerm (PlAtom a) = showPlAtom a showPlTerm (PlInt i) = show i showPlTerm (PlFloat f) = show f showPlTerm (PlStruct f []) = showPlAtom f showPlTerm (PlStruct f args@(h:t)) | f=="." && length args == 2 -- a Prolog list = "[" ++ showPlTerm h ++ showPlListElems (head t) ++ "]" | (f=="," || all (`elem` specialChars) f) && length args == 2 -- infix op = "("++ showPlTerm (args!!0) ++ f ++ showPlTerm (args!!1) ++")" | otherwise = showPlAtom f ++"("++ intercalate "," (map showPlTerm args) ++")" showPlListElems :: PlTerm -> String showPlListElems xs = case xs of PlAtom "[]" -> "" PlStruct f [y,ys] -> if f=="." then "," ++ showPlTerm y ++ showPlListElems ys else "|" ++ showPlTerm ys _ -> "|" ++ showPlTerm xs showPlAtom :: String -> String showPlAtom a = if a=="[]" || (all (\c -> isAlphaNum c || c=='_') a && isLower (head a)) || all (`elem` specialChars) a then a else '\'': (concatMap (\c->if c=='\'' then "\\\'" else [c]) a) ++"\'" specialChars :: String specialChars = "+-*/<=>`\\:.?@#$&^~" ---------------------------------------------------------------------------- -- Optimize a Prolog clause: "head :- b1,X=Y,b2" is replaced by -- "head :- b1,[X/Y]b2" if X does not occur in head and b1 optimizeClause :: PlClause -> PlClause optimizeClause (PlClause pred args body) = PlClause pred args (optimizeBody (unionMap varsOf args) body) optimizeClause (PlDirective body) = PlDirective (optimizeBody [] body) optimizeClause (PlQuery body) = PlQuery (optimizeBody [] body) optimizeBody :: [String] -> [PlGoal] -> [PlGoal] optimizeBody _ [] = [] optimizeBody vars (PlCond cond tgoal fgoal : lits) = let ocond = optimizeBody vars cond ocvars = union vars (unionMap varsOfLit cond) otgoal = optimizeBody ocvars tgoal ofgoal = optimizeBody ocvars fgoal in PlCond ocond otgoal ofgoal : optimizeBody (union ocvars (unionMap varsOfLit (otgoal++ofgoal))) lits optimizeBody vars (PlLit pred args : lits) | pred=="=" && isPlVar (head args) && (varOf (head args) `notElem` vars) = optimizeBody (union vars (varsOf (args!!1))) (map (replaceInLit (varOf (head args)) (args!!1)) lits) | pred=="=" && isPlVar (args!!1) && (varOf (args!!1) `notElem` vars) = optimizeBody (union vars (varsOf (args!!0))) (map (replaceInLit (varOf (args!!1)) (args!!0)) lits) | otherwise = PlLit pred args : optimizeBody (union vars (unionMap varsOf args)) lits replaceInLit :: String -> PlTerm -> PlGoal -> PlGoal replaceInLit x y (PlLit pred args) = PlLit pred (map (replaceInTerm x y) args) replaceInLit x y (PlCond cond tgoal fgoal) = PlCond (map (replaceInLit x y) cond) (map (replaceInLit x y) tgoal) (map (replaceInLit x y) fgoal) replaceInTerm :: String -> PlTerm -> PlTerm -> PlTerm replaceInTerm x y (PlVar v) = if x==v then y else PlVar v replaceInTerm _ _ (PlAtom a) = PlAtom a replaceInTerm _ _ (PlInt i) = PlInt i replaceInTerm _ _ (PlFloat f) = PlFloat f replaceInTerm x y (PlStruct f args) = PlStruct f (map (replaceInTerm x y) args) varsOfLit :: PlGoal -> [String] varsOfLit (PlLit _ args) = unionMap varsOf args varsOfLit (PlCond g1 g2 g3) = unionMap varsOfLit (g1++g2++g3) varsOf :: PlTerm -> [String] varsOf (PlVar v) = [v] varsOf (PlAtom _) = [] varsOf (PlInt _) = [] varsOf (PlFloat _) = [] varsOf (PlStruct _ args) = unionMap varsOf args isPlVar :: PlTerm -> Bool isPlVar t = case t of PlVar _ -> True _ -> False varOf :: PlTerm -> String varOf (PlVar v) = v unionMap :: (a -> [b]) -> [a] -> [b] unionMap f = foldr union [] . map f ---------------------------------------------------------------------------- curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/PropertyFile.curry000066400000000000000000000042131305333611600247420ustar00rootroot00000000000000------------------------------------------------------------------------------ --- A library to read and update files containing properties in the usual --- equational syntax, i.e., a property is defined by a line of the form --- `prop=value` where `prop` starts with a letter. --- All other lines (e.g., blank lines or lines starting with `#` are --- considered as comment lines and are ignored. --- --- @author Michael Hanus --- @version August 2006 --- @category general ------------------------------------------------------------------------------ module PropertyFile(readPropertyFile,updatePropertyFile) where import Directory import IOExts import Char --- Reads a property file and returns the list of properties. --- Returns empty list if the property file does not exist. readPropertyFile :: String -> IO [(String,String)] readPropertyFile file = do pfexists <- doesFileExist file if pfexists then do rcs <- readCompleteFile file -- to avoid open file handles return $ splitEqs . filter (\l->not (null l) && isAlpha (head l)) . lines $ rcs else return [] where splitEqs [] = [] splitEqs (eq:eqs) = case break (=='=') eq of (prop,_:val) -> (prop,val) : splitEqs eqs _ -> splitEqs eqs --- Update a property in a property file or add it, if it is not already --- there. --- @param file - the name of the property file --- @param pname - the name of the property --- @param pvalue - the new value of the property updatePropertyFile :: String -> String -> String -> IO () updatePropertyFile file pname pval = do props <- readPropertyFile file if lookup pname props == Nothing then appendFile file (pname++"="++pval++"\n") else changePropertyInFile file pname pval --- Change a property in a property file. changePropertyInFile :: String -> String -> String -> IO () changePropertyInFile file pname pval = do updateFile (\rcs -> unlines . map changeProp . lines $ rcs) file where changeProp l = let (s1,s2) = break (=='=') l in if null l || not (isAlpha (head l)) || null s2 then l else if s1==pname then s1++"="++pval else l curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/README.md000066400000000000000000000010121305333611600225010ustar00rootroot00000000000000Curry Libraries =============== This repository contains the standard libraries of the Curry distributions PAKCS and KiCS2. Since there are slight differences in the implementation of some libraries that are available for both PAKCS and KiCS2, libraries specific to PAKCS are suffixed by `.pakcs`. During the make process of PAKCS, these libraries are copied into the default `lib` directory where the suffix is removed. The makefiles `Makefiles.*.install` are responsible for this system-specific installation process. curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Random.curry000066400000000000000000000075661305333611600235540ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for pseudo-random number generation in Curry. --- --- This library provides operations for generating pseudo-random --- number sequences. --- For any given seed, the sequences generated by the operations --- in this module should be **identical** to the sequences --- generated by the `java.util.Random package`. --- --- The algorithm is taken from --- . --- There is an assumption that all operations are implicitly --- executed mod 2^32 (unsigned 32-bit integers) !!! --- GHC computes between -2^29 and 2^29-1, thus the sequence --- is NOT as random as one would like. --- --- m_w = ; /* must not be zero */ --- m_z = ; /* must not be zero */ --- --- uint get_random() --- { --- m_z = 36969 * (m_z & 65535) + (m_z >> 16); --- m_w = 18000 * (m_w & 65535) + (m_w >> 16); --- return (m_z << 16) + m_w; /* 32-bit result */ --- } --- --- @author Sergio Antoy (with extensions by Michael Hanus) --- @version February 2016 --- @category algorithm ------------------------------------------------------------------------------ module Random ( nextInt, nextIntRange, nextBoolean, getRandomSeed , shuffle ) where import Integer ( abs ) import System ( getCPUTime ) import Time zfact = 36969 wfact = 18000 two16 = 65536 large = 536870911 -- 2^29 - 1 ------------------------------------------------------------------ -- Public Operations ------------------------------------------------------------------ --- Returns a sequence of pseudorandom, integer values. --- --- @param seed - The seed of the random sequence. nextInt :: Int -> [Int] nextInt seed = let ns = if seed == 0 then 1 else seed next2 mw mz = let mza = zfact * (mz `mod` two16) + (mz * two16) mwa = wfact * (mw `mod` two16) + (mw * two16) tmp = (mza `div` two16 + mwa) res = if tmp < 0 then tmp+large else tmp in res : next2 mwa mza in next2 ns ns --- Returns a pseudorandom sequence of values --- between 0 (inclusive) and the specified value (exclusive). --- --- @param seed - The seed of the random sequence. --- @param n - The bound on the random number to be returned. --- Must be positive. nextIntRange :: Int -> Int -> [Int] nextIntRange seed n | n>0 = map (`mod` n) (nextInt seed) --- Returns a pseudorandom sequence of boolean values. --- --- @param seed - The seed of the random sequence. nextBoolean :: Int -> [Bool] nextBoolean seed = map (/= 0) (nextInt seed) --- Returns a time-dependent integer number as a seed for really random numbers. --- Should only be used as a seed for pseudorandom number sequence --- and not as a random number since the precision is limited to milliseconds getRandomSeed :: IO Int getRandomSeed = getClockTime >>= \time -> getCPUTime >>= \msecs -> let (CalendarTime y mo d h m s _) = toUTCTime time in return ((y+mo+d+h+m*s*(msecs+1)) `mod` two16) --- Computes a random permutation of the given list. --- --- @param rnd random seed --- @param l lists to shuffle --- @return shuffled list --- shuffle :: Int -> [a] -> [a] shuffle rnd xs = shuffleWithLen (nextInt rnd) (length xs) xs shuffleWithLen :: [Int] -> Int -> [a] -> [a] shuffleWithLen [] _ _ = error "Internal error in Random.shuffleWithLen" shuffleWithLen (r:rs) len xs | len == 0 = [] | otherwise = z : shuffleWithLen rs (len-1) (ys++zs) where (ys,z:zs) = splitAt (abs r `mod` len) xs {- Simple tests and examples testInt = take 20 (nextInt 0) testIntRange = take 120 (nextIntRange 0 6) testBoolean = take 20 (nextBoolean 0) reallyRandom = do seed <- getRandomSeed putStrLn (show (take 20 (nextIntRange seed 100))) -} curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Random.curry.pakcs000066400000000000000000000121731305333611600246420ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for pseudo-random number generation in Curry. --- --- This library provides operations for generating pseudo-random --- number sequences. --- For any given seed, the sequences generated by the operations --- in this module should be **identical** to the sequences --- generated by the `java.util.Random package`. --- --- The algorithm is a linear congruential pseudo-random number generator --- described in --- Donald E. Knuth, _The Art of Computer Programming_, --- Volume 2: _Seminumerical Algorithms_, section 3.2.1. --- --- @author Sergio Antoy (with extensions by Michael Hanus) --- @version February 2016 --- @category algorithm ------------------------------------------------------------------------------ module Random ( nextInt, nextIntRange, nextBoolean, getRandomSeed , shuffle ) where import Integer ( abs ) import System ( getCPUTime ) import Time ------------------------------------------------------------------ -- Private Operations ------------------------------------------------------------------ -- a few constants multiplier = 25214903917 addend = 11 powermask = 48 mask = 281474976710656 -- 2^powermask intsize = 32 intspan = 4294967296 -- 2^intsize intlimit = 2147483648 -- 2^(intsize-1) -- the basic sequence of random values sequence seed = next : sequence next where next = nextseed seed -- auxiliary private operations nextseed seed = (seed * multiplier + addend) `mod` mask xor x y = if (x==0) && (y==0) then 0 else lastBit + 2 * restBits where lastBit = if (x `mod` 2) == (y `mod` 2) then 0 else 1 restBits = xor (x `div` 2) (y `div` 2) power base exp = binary 1 base exp where binary x b e = if (e == 0) then x else binary (x * if (e `mod` 2 == 1) then b else 1) (b * b) (e `div` 2) nextIntBits seed bits = map adjust list where init = (xor seed multiplier) `mod` mask list = sequence init shift = power 2 (powermask - bits) adjust x = if arg > intlimit then arg - intspan else arg where arg = (x `div` shift) `mod` intspan ------------------------------------------------------------------ -- Public Operations ------------------------------------------------------------------ --- Returns a sequence of pseudorandom, uniformly distributed 32-bits --- integer values. All 232 --- possible integer values are produced with --- (approximately) equal probability. --- --- @param seed - The seed of the random sequence. nextInt :: Int -> [Int] nextInt seed = nextIntBits seed intsize --- Returns a pseudorandom, uniformly distributed sequence of values --- between 0 (inclusive) and the specified value (exclusive). --- Each value is a 32-bits positive integer. --- All `n` possible values are produced with (approximately) equal --- probability. --- @param seed - The seed of the random sequence. --- @param n - The bound on the random number to be returned. --- Must be positive. nextIntRange :: Int -> Int -> [Int] nextIntRange seed n | n>0 = if power_of_2 n then map adjust_a seq else map adjust_b (filter adjust_c seq) where seq = nextIntBits seed (intsize - 1) adjust_a x = (n * x) `div` intlimit adjust_b x = x `mod` n adjust_c x = x - (x `mod` n) + (n - 1) >= 0 power_of_2 k = k == 2 || k > 2 && k `mod` 2 == 0 && power_of_2 (k `div` 2) --- Returns a pseudorandom, uniformly distributed sequence of --- boolean values. The values `True` and `False` are produced with --- (approximately) equal probability. --- @param seed - The seed of the random sequence. nextBoolean :: Int -> [Bool] nextBoolean seed = map (/= 0) (nextIntBits seed 1) --- Returns a time-dependent integer number as a seed for really random numbers. --- Should only be used as a seed for pseudorandom number sequence --- and not as a random number since the precision is limited to milliseconds getRandomSeed :: IO Int getRandomSeed = getClockTime >>= \time -> getCPUTime >>= \msecs -> let (CalendarTime y mo d h m s _) = toUTCTime time in return ((y+mo+d+h+m*s*msecs) `mod` mask) --- Computes a random permutation of the given list. --- --- @param rnd random seed --- @param l lists to shuffle --- @return shuffled list --- shuffle :: Int -> [a] -> [a] shuffle rnd xs = shuffleWithLen (nextInt rnd) (length xs) xs shuffleWithLen :: [Int] -> Int -> [a] -> [a] shuffleWithLen [] _ _ = error "Internal error in Random.shuffleWithLen" shuffleWithLen (r:rs) len xs | len == 0 = [] | otherwise = z : shuffleWithLen rs (len-1) (ys++zs) where (ys,z:zs) = splitAt (abs r `mod` len) xs {- Simple tests and examples testInt = take 20 (nextInt 0) testIntRange = take 120 (nextIntRange 0 6) testBoolean = take 20 (nextBoolean 0) reallyRandom = do seed <- getRandomSeed putStrLn (show (take 20 (nextIntRange seed 100))) -} curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Read.curry000066400000000000000000000036631305333611600232010ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library with some functions for reading special tokens. --- --- This library is included for backward compatibility. --- You should use the library ReadNumeric which provides a better interface --- for these functions. --- --- @author Michael Hanus --- @version January 2000 --- @category general ------------------------------------------------------------------------------ module Read(readNat,readInt,readHex) where import Char --- Read a natural number in a string. --- The string might contain leadings blanks and the the number is read --- up to the first non-digit. readNat :: String -> Int -- result >= 0 readNat l = readNatPrefix (dropWhile (\c->c==' ') l) 0 where readNatPrefix [] n = n readNatPrefix (c:cs) n = let oc = ord c in if oc>=ord '0' && oc<=ord '9' then readNatPrefix cs (n*10+oc-(ord '0')) else n --- Read a (possibly negative) integer in a string. --- The string might contain leadings blanks and the the integer is read --- up to the first non-digit. readInt :: String -> Int -- result >= 0 readInt l = readIntPrefix (dropWhile (\c->c==' ') l) where readIntPrefix [] = 0 readIntPrefix (c:cs) = if c=='-' then - (readNat cs) else readNat (c:cs) --- Read a hexadecimal number in a string. --- The string might contain leadings blanks and the the integer is read --- up to the first non-heaxdecimal digit. readHex :: String -> Int -- result >= 0 readHex l = readHexPrefix (dropWhile (\c->c==' ') l) 0 where readHexPrefix [] n = n readHexPrefix (c:cs) n = let cv = hex2int c in if cv>=0 then readHexPrefix cs (n*16+cv) else n hex2int c = if isDigit c then ord c - ord '0' else if ord c >= ord 'A' && ord c <= ord 'F' then ord c - ord 'A' + 10 else -1 -- end of library Read curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/ReadNumeric.curry000066400000000000000000000076401305333611600245230ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library with some functions for reading and converting numeric tokens. -- --- @author Michael Hanus, Frank Huch, Bjoern Peemoeller --- @version November 2016 --- @category general ------------------------------------------------------------------------------ module ReadNumeric ( readInt, readNat, readHex, readOct, readBin ) where import Char (digitToInt, isBinDigit, isOctDigit, isDigit, isHexDigit, isSpace) --- Read a (possibly negative) integer as a first token in a string. --- The string might contain leadings blanks and the integer is read --- up to the first non-digit. --- If the string does not start with an integer token, `Nothing` is returned, --- otherwise the result is `Just (v, s)`, where `v` is the value of the integer --- and `s` is the remaing string without the integer token. readInt :: String -> Maybe (Int, String) readInt str = case dropWhile isSpace str of [] -> Nothing '-':str1 -> maybe Nothing (\ (val,rstr) -> Just (-val,rstr)) (readNat str1) str1 -> readNat str1 --- Read a natural number as a first token in a string. --- The string might contain leadings blanks and the number is read --- up to the first non-digit. --- If the string does not start with a natural number token, --- `Nothing` is returned, --- otherwise the result is `Just (v, s)` where `v` is the value of the number --- and s is the remaing string without the number token. readNat :: String -> Maybe (Int, String) readNat str = readNumPrefix (dropWhile isSpace str) Nothing 10 isDigit digitToInt --- Read a hexadecimal number as a first token in a string. --- The string might contain leadings blanks and the number is read --- up to the first non-hexadecimal digit. --- If the string does not start with a hexadecimal number token, --- `Nothing` is returned, --- otherwise the result is `Just (v, s)` where `v` is the value of the number --- and s is the remaing string without the number token. readHex :: String -> Maybe (Int, String) readHex l = readNumPrefix (dropWhile isSpace l) Nothing 16 isHexDigit digitToInt --- Read an octal number as a first token in a string. --- The string might contain leadings blanks and the number is read --- up to the first non-octal digit. --- If the string does not start with an octal number token, --- `Nothing` is returned, --- otherwise the result is `Just (v, s)` where `v` is the value of the number --- and s is the remaing string without the number token. readOct :: String -> Maybe (Int, String) readOct l = readNumPrefix (dropWhile isSpace l) Nothing 8 isOctDigit digitToInt --- Read a binary number as a first token in a string. --- The string might contain leadings blanks and the number is read --- up to the first non-binary digit. --- If the string does not start with a binary number token, --- `Nothing` is returned, --- otherwise the result is `Just (v, s)` where `v` is the value of the number --- and s is the remaing string without the number token. readBin :: String -> Maybe (Int, String) readBin l = readNumPrefix (dropWhile isSpace l) Nothing 2 isBinDigit digitToInt --- Read an integral number prefix where the value of an already read number --- prefix is provided as the second argument. --- The third argument is the base, the fourth argument --- is a predicate to distinguish valid digits, and the fifth argument converts --- valid digits into integer values. readNumPrefix :: String -> Maybe Int -> Int -> (Char -> Bool) -> (Char -> Int) -> Maybe (Int, String) readNumPrefix [] Nothing _ _ _ = Nothing readNumPrefix [] (Just n) _ _ _ = Just (n,"") readNumPrefix (c:cs) (Just n) base isdigit valueof | isdigit c = readNumPrefix cs (Just (base*n+valueof c)) base isdigit valueof | otherwise = Just (n,c:cs) readNumPrefix (c:cs) Nothing base isdigit valueof | isdigit c = readNumPrefix cs (Just (valueof c)) base isdigit valueof | otherwise = Nothing curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/ReadShowTerm.curry000066400000000000000000000142251305333611600246660ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for converting ground terms to strings and vice versa. --- --- @author Michael Hanus --- @version April 2005 --- @category general ------------------------------------------------------------------------------ module ReadShowTerm(showTerm,showQTerm,readQTerm,readsQTerm, readsUnqualifiedTerm,readUnqualifiedTerm,readsTerm,readTerm, readQTermFile,readQTermListFile, writeQTermFile,writeQTermListFile) where import Char(isSpace) --- Transforms a ground(!) term into a string representation --- in standard prefix notation. --- Thus, showTerm suspends until its argument is ground. --- This function is similar to the prelude function show --- but can read the string back with readUnqualifiedTerm --- (provided that the constructor names are unique without the module --- qualifier). showTerm :: _ -> String showTerm x = prim_showTerm $## x prim_showTerm :: _ -> String prim_showTerm external --- Transforms a ground(!) term into a string representation --- in standard prefix notation. --- Thus, showTerm suspends until its argument is ground. --- Note that this function differs from the prelude function show --- since it prefixes constructors with their module name --- in order to read them back with readQTerm. showQTerm :: _ -> String showQTerm x = prim_showQTerm $## x prim_showQTerm :: _ -> String prim_showQTerm external --- Transform a string containing a term in standard prefix notation --- without module qualifiers into the corresponding data term. --- The first argument is a non-empty list of module qualifiers that are tried to --- prefix the constructor in the string in order to get the qualified constructors --- (that must be defined in the current program!). --- In case of a successful parse, the result is a one element list --- containing a pair of the data term and the remaining unparsed string. readsUnqualifiedTerm :: [String] -> String -> [(_,String)] readsUnqualifiedTerm [] _ = error "ReadShowTerm.readsUnqualifiedTerm: list of module prefixes is empty" readsUnqualifiedTerm (prefix:prefixes) s = readsUnqualifiedTermWithPrefixes (prefix:prefixes) s readsUnqualifiedTermWithPrefixes :: [String] -> String -> [(_,String)] readsUnqualifiedTermWithPrefixes prefixes s = (prim_readsUnqualifiedTerm $## prefixes) $## s prim_readsUnqualifiedTerm :: [String] -> String -> [(_,String)] prim_readsUnqualifiedTerm external --- Transforms a string containing a term in standard prefix notation --- without module qualifiers into the corresponding data term. --- The first argument is a non-empty list of module qualifiers that are tried to --- prefix the constructor in the string in order to get the qualified constructors --- (that must be defined in the current program!). --- --- Example: readUnqualifiedTerm ["Prelude"] "Just 3" --- evaluates to (Just 3) readUnqualifiedTerm :: [String] -> String -> _ readUnqualifiedTerm prefixes s = case result of [(term,tail)] -> if all isSpace tail then term else error ("ReadShowTerm.readUnqualifiedTerm: no parse, unmatched string after term: "++tail) [] -> error "ReadShowTerm.readUnqualifiedTerm: no parse" _ -> error "ReadShowTerm.readUnqualifiedTerm: ambiguous parse" where result = readsUnqualifiedTerm prefixes s --- For backward compatibility. Should not be used since their use can be problematic --- in case of constructors with identical names in different modules. readsTerm :: String -> [(_,String)] readsTerm s = prim_readsUnqualifiedTerm [] $## s --- For backward compatibility. Should not be used since their use can be problematic --- in case of constructors with identical names in different modules. readTerm :: String -> _ readTerm s = case result of [(term,tail)] -> if all isSpace tail then term else error ("ReadShowTerm.readTerm: no parse, unmatched string after term: "++tail) [] -> error "ReadShowTerm.readTerm: no parse" _ -> error "ReadShowTerm.readTerm: ambiguous parse" where result = prim_readsUnqualifiedTerm [] $## s --- Transforms a string containing a term in standard prefix notation --- with qualified constructor names into the corresponding data term. --- In case of a successful parse, the result is a one element list --- containing a pair of the data term and the remaining unparsed string. readsQTerm :: String -> [(_,String)] readsQTerm s = prim_readsQTerm $## s prim_readsQTerm :: String -> [(_,String)] prim_readsQTerm external --- Transforms a string containing a term in standard prefix notation --- with qualified constructor names into the corresponding data term. readQTerm :: String -> _ readQTerm s = case result of [(term,tail)] -> if all isSpace tail then term else error "ReadShowTerm.readQTerm: no parse" [] -> error "ReadShowTerm.readQTerm: no parse" _ -> error "ReadShowTerm.readQTerm: ambiguous parse" where result = readsQTerm s --- Reads a file containing a string representation of a term --- in standard prefix notation and returns the corresponding data term. readQTermFile :: String -> IO _ readQTermFile file = readFile file >>= return . readQTerm --- Reads a file containing lines with string representations of terms --- of the same type and returns the corresponding list of data terms. readQTermListFile :: String -> IO [_] readQTermListFile file = readFile file >>= return . map readQTerm . lines --- Writes a ground term into a file in standard prefix notation. --- @param filename - The name of the file to be written. --- @param term - The term to be written to the file as a string. writeQTermFile :: String -> _ -> IO () writeQTermFile filename term = writeFile filename (showQTerm term) --- Writes a list of ground terms into a file. --- Each term is written into a separate line which might be useful --- to modify the file with a standard text editor. --- @param filename - The name of the file to be written. --- @param terms - The list of terms to be written to the file. writeQTermListFile :: String -> [_] -> IO () writeQTermListFile filename terms = writeFile filename (unlines (map showQTerm terms)) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/ReadShowTerm.prim_c2p000066400000000000000000000012661305333611600252360ustar00rootroot00000000000000 prim_readshowterm prim_showQTerm prim_readshowterm prim_showTerm prim_readshowterm prim_readsQTerm prim_readshowterm prim_readsUnqualifiedTerm curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/RedBlackTree.curry000066400000000000000000000223131305333611600246060ustar00rootroot00000000000000--------------------------------------------------------------------------- --- Library with an implementation of red-black trees: ---

--- Serves as the base for both TableRBT and SetRBT --- All the operations on trees are generic, i.e., one has to provide --- two explicit order predicates ("lessThan" and "eq"below) --- on elements. --- --- @author Johannes Koj, Michael Hanus, Bernd Brassel --- @version March 2005 --- @category algorithm ---------------------------------------------------------------------------- module RedBlackTree ( RedBlackTree, empty, isEmpty, lookup, update , tree2list, sortBy, newTreeLike, setInsertEquivalence, delete ) where ---------------------------------------------------------------------------- -- the main interface: --- A red-black tree consists of a tree structure and three order predicates. --- These predicates generalize the red black tree. They define --- 1) equality when inserting into the tree
--- eg for a set eqInsert is (==), --- for a multiset it is (\ _ _ -> False) --- for a lookUp-table it is ((==) . fst) --- 2) equality for looking up values --- eg for a set eqLookUp is (==), --- for a multiset it is (==) --- for a lookUp-table it is ((==) . fst) --- 3) the (less than) relation for the binary search tree data RedBlackTree a = RedBlackTree (a -> a -> Bool) -- equality for insertion (a -> a -> Bool) -- equality for lookup (a -> a -> Bool) -- lessThan for search (Tree a) -- contents --- The three relations are inserted into the structure by function empty. --- Returns an empty tree, i.e., an empty red-black tree --- augmented with the order predicates. empty :: (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> RedBlackTree a empty eqInsert eqLookUp lessThan = RedBlackTree eqInsert eqLookUp lessThan Empty --- Test on emptyness isEmpty :: RedBlackTree _ -> Bool isEmpty (RedBlackTree _ _ _ Empty) = True isEmpty (RedBlackTree _ _ _ (Tree _ _ _ _)) = False --- Creates a new empty red black tree from with the same ordering as a give one. newTreeLike :: RedBlackTree a -> RedBlackTree a newTreeLike (RedBlackTree eqIns eqLk lt _) = RedBlackTree eqIns eqLk lt Empty --- Returns an element if it is contained in a red-black tree. --- @param p - a pattern for an element to look up in the tree --- @param t - a red-black tree --- @return the contained True if p matches in t lookup :: a -> RedBlackTree a -> Maybe a lookup p (RedBlackTree _ eqLk lt t) = lookupTree eqLk lt p t lookupTree :: (a -> a -> Bool) -> (a -> a -> Bool) -> a -> Tree a -> Maybe a lookupTree _ _ _ Empty = Nothing lookupTree eq lt p (Tree _ e l r) | eq p e = Just e | lt p e = lookupTree eq lt p l | otherwise = lookupTree eq lt p r --- Updates/inserts an element into a RedBlackTree. update :: a -> RedBlackTree a -> RedBlackTree a update e (RedBlackTree eqIns eqLk lt t) = RedBlackTree eqIns eqLk lt (updateTree eqIns lt e t) updateTree :: (a -> a -> Bool) -> (a -> a -> Bool) -> a -> Tree a -> Tree a updateTree eq lt e t = let (Tree _ e2 l r) = upd t in Tree Black e2 l r where upd Empty = Tree Red e Empty Empty upd (Tree c e2 l r) | eq e e2 = Tree c e l r | lt e e2 = balanceL (Tree c e2 (upd l) r) | otherwise = balanceR (Tree c e2 l (upd r)) --- Deletes entry from red black tree. delete :: a -> RedBlackTree a -> RedBlackTree a delete e (RedBlackTree eqIns eqLk lt t) = RedBlackTree eqIns eqLk lt (blackenRoot (deleteTree eqLk lt e t)) where blackenRoot Empty = Empty blackenRoot (Tree _ x l r) = Tree Black x l r deleteTree :: (a -> a -> Prelude.Bool) -> (a -> a -> Prelude.Bool) -> a -> Tree a -> Tree a deleteTree _ _ _ Empty = Empty -- no error for non existence deleteTree eq lt e (Tree c e2 l r) | eq e e2 = if isEmptyTree l then addColor c r else if isEmptyTree r then addColor c l else let el = rightMost l in delBalanceL (Tree c el (deleteTree eq lt el l) r) | lt e e2 = delBalanceL (Tree c e2 (deleteTree eq lt e l) r) | otherwise = delBalanceR (Tree c e2 l (deleteTree eq lt e r)) where addColor DoublyBlack tree = tree -- should not occur addColor Red tree = tree addColor Black Empty = Empty addColor Black (Tree Red x lx rx) = Tree Black x lx rx addColor Black (Tree Black x lx rx) = Tree DoublyBlack x lx rx addColor Black (Tree DoublyBlack x lx rx) = Tree DoublyBlack x lx rx rightMost Empty = error "RedBlackTree.rightMost" rightMost (Tree _ x _ rx) = if isEmptyTree rx then x else rightMost rx --- Transforms a red-black tree into an ordered list of its elements. tree2list :: RedBlackTree a -> [a] tree2list (RedBlackTree _ _ _ t) = tree2listTree t tree2listTree :: Tree a -> [a] tree2listTree tree = t2l tree [] where t2l Empty es = es t2l (Tree _ e l r) es = t2l l (e : t2l r es) --- Generic sort based on insertion into red-black trees. --- The first argument is the order for the elements. sortBy :: (a -> a -> Bool) -> [a] -> [a] sortBy cmp xs = tree2list (foldr update (empty (\_ _->False) (==) cmp) xs) --- For compatibility with old version only setInsertEquivalence :: (a -> a -> Bool) -> RedBlackTree a -> RedBlackTree a setInsertEquivalence eqIns (RedBlackTree _ eqLk lt t) = RedBlackTree eqIns eqLk lt t ---------------------------------------------------------------------------- -- implementation of red-black trees: rbt :: RedBlackTree a -> Tree a rbt (RedBlackTree _ _ _ t) = t --- The colors of a node in a red-black tree. data Color = Red | Black | DoublyBlack --- The structure of red-black trees. data Tree a = Tree Color a (Tree a) (Tree a) | Empty isEmptyTree :: Tree _ -> Bool isEmptyTree Empty = True isEmptyTree (Tree _ _ _ _) = False isBlack :: Tree _ -> Bool isBlack Empty = True isBlack (Tree c _ _ _) = c == Black isRed :: Tree _ -> Bool isRed Empty = False isRed (Tree c _ _ _) = c == Red isDoublyBlack :: Tree _ -> Bool isDoublyBlack Empty = True isDoublyBlack (Tree c _ _ _) = c == DoublyBlack left :: Tree a -> Tree a left Empty = error "RedBlackTree.left" left (Tree _ _ l _) = l right :: Tree a -> Tree a right Empty = error "RedBlackTree.right" right (Tree _ _ _ r) = r singleBlack :: Tree a -> Tree a singleBlack Empty = Empty singleBlack (Tree Red x l r) = Tree Red x l r singleBlack (Tree Black x l r) = Tree Black x l r singleBlack (Tree DoublyBlack x l r) = Tree Black x l r --- for the implementation of balanceL and balanceR refer to picture 3.5, page 27, --- Okasaki "Purely Functional Data Structures" balanceL :: Tree a -> Tree a balanceL tree | isRed leftTree && isRed (left leftTree) = let Tree _ z (Tree _ y (Tree _ x a b) c) d = tree in Tree Red y (Tree Black x a b) (Tree Black z c d) | isRed leftTree && isRed (right leftTree) = let Tree _ z (Tree _ x a (Tree _ y b c)) d = tree in Tree Red y (Tree Black x a b) (Tree Black z c d) | otherwise = tree where leftTree = left tree balanceR :: Tree a -> Tree a balanceR tree | isRed rightTree && isRed (right rightTree) = let Tree _ x a (Tree _ y b (Tree _ z c d)) = tree in Tree Red y (Tree Black x a b) (Tree Black z c d) | isRed rightTree && isRed (left rightTree) = let Tree _ x a (Tree _ z (Tree _ y b c) d) = tree in Tree Red y (Tree Black x a b) (Tree Black z c d) | otherwise = tree where rightTree = right tree --- balancing after deletion delBalanceL :: Tree a -> Tree a delBalanceL tree = if isDoublyBlack (left tree) then reviseLeft tree else tree reviseLeft :: Tree a -> Tree a reviseLeft tree | isEmptyTree r = tree | blackr && isRed (left r) = let Tree col x a (Tree _ z (Tree _ y b c) d) = tree in Tree col y (Tree Black x (singleBlack a) b) (Tree Black z c d) | blackr && isRed (right r) = let Tree col x a (Tree _ y b (Tree _ z c d)) = tree in Tree col y (Tree Black x (singleBlack a) b) (Tree Black z c d) | blackr = let Tree col x a (Tree _ y b c) = tree in Tree (if col==Red then Black else DoublyBlack) x (singleBlack a) (Tree Red y b c) | otherwise = let Tree _ x a (Tree _ y b c) = tree in Tree Black y (reviseLeft (Tree Red x a b)) c where r = right tree blackr = isBlack r delBalanceR :: Tree a -> Tree a delBalanceR tree = if isDoublyBlack (right tree) then reviseRight tree else tree reviseRight :: Tree a -> Tree a reviseRight tree | isEmptyTree l = tree | blackl && isRed (left l) = let Tree col x (Tree _ y (Tree _ z d c) b) a = tree in Tree col y (Tree Black z d c) (Tree Black x b (singleBlack a)) | blackl && isRed (right l) = let Tree col x (Tree _ z d (Tree _ y c b)) a = tree in Tree col y (Tree Black z d c) (Tree Black x b (singleBlack a)) | blackl = let Tree col x (Tree _ y c b) a = tree in Tree (if col==Red then Black else DoublyBlack) x (Tree Red y c b) (singleBlack a) | otherwise = let Tree _ x (Tree _ y c b) a = tree in Tree Black y c (reviseRight (Tree Red x b a)) where l = left tree blackl = isBlack l curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/RegExp.curry000066400000000000000000000071571305333611600235220ustar00rootroot00000000000000------------------------------------------------------------------------------ --- A library to defined and match regular expressions. --- This library is used to translated integrated code in the form --- of POSIX extended regular expressions into Curry programs. --- --- @author Jasper Sikorra --- @version January 2013 --- @category general ------------------------------------------------------------------------------ -- TODO -- - Stard and End are not implemented -- - No function to match only a part of a lists module RegExp(match, RegExp, ORegExp(..)) where import List --- Data type for regex representation in Curry type RegExp a = [ORegExp a] data ORegExp a = Nil | Literal a | Xor (RegExp a) (RegExp a) | Star (RegExp a) | Plus (RegExp a) | AnyLiteral | Bracket [Either a (a,a)] | NegBracket [Either a (a,a)] | Start (RegExp a) | End (RegExp a) | Times (Int,Int) (RegExp a) --- The match function is used to match lists with regular expressions --- @param s - The input list --- @param r - The regular expression --- @result True if matched else False match :: [a] -> RegExp a -> Bool match s re = case re of [] -> s == [] (Nil:ors) -> match s ors (Xor or1 or2:ors) -> match s (or1 ++ ors) || match s (or2 ++ ors) (Literal c:ors) -> case s of [] -> False (d:ds) -> if (d == c) then match ds ors else False (Star r:ors) -> matchstar s r ors (Plus r:ors) -> matchplus s r ors (AnyLiteral:ors) -> case s of [] -> False (_:ds) -> match ds ors (Bracket b:ors) -> case s of [] -> False (d:ds) -> (matchbracket b d) && match ds ors (NegBracket b:ors) -> case s of [] -> False (d:ds) -> not (matchbracket b d) && match ds ors (Start _:_) -> failed (End _:_) -> failed (Times (n,m) r:ors) -> matchtimes s n m r ors -- Matching with a star matchstar :: [a] -> RegExp a -> RegExp a -> Bool matchstar st r rgx = (||) (match st rgx) (tryeach (map (\x -> match x r) (inits st)) (tails st) r rgx) tryeach :: [Bool] -> [[a]] -> RegExp a -> RegExp a -> Bool tryeach [] [] _ _ = False tryeach (b:bs) (t:ts) r rgx = (||) (if b then (match t rgx || matchstar t r rgx) else False) (tryeach bs ts r rgx) -- Matching with a plus matchplus :: [a] -> RegExp a -> RegExp a -> Bool matchplus st r rgx = tryeach (map (\x -> match x r) ini) tls r rgx where ini = tail (inits st) tls = tail (tails st) -- Matching with a bracket matchbracket :: [Either a (a,a)] -> a -> Bool matchbracket [] _ = False matchbracket (Left c:es) d | c == d = True | c /= d = matchbracket es d matchbracket (Right (c1,c2):es) d = (||) (d >= c1 && d <= c2) (matchbracket es d) -- Matching an amount of times between a range matchtimes :: [a] -> Int -> Int -> RegExp a -> RegExp a -> Bool matchtimes s n m r rgx | m == 0 = match s rgx | m > 0 = tryeachRestricted (m-n) (map (\x -> match x mr) (inits s)) (tails s) r rgx where mr = concat (replicate n r) tryeachRestricted :: Int -> [Bool] -> [[a]] -> RegExp a -> RegExp a -> Bool tryeachRestricted _ [] [] _ _ = False tryeachRestricted m (b:bs) (t:ts) r rgx = (||) (if b then (match t rgx || matchtimes t 1 m r rgx) else False) (tryeachRestricted m bs ts r rgx) ------------------------------------------------------------------------------ curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Rewriting/000077500000000000000000000000001305333611600232025ustar00rootroot00000000000000curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Rewriting/CriticalPairs.curry000066400000000000000000000055551305333611600270330ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for representation and computation of critical pairs. --- --- @author Jan-Hendrik Matthes --- @version August 2016 --- @category algorithm ------------------------------------------------------------------------------ module Rewriting.CriticalPairs ( CPair , showCPair, showCPairs, cPairs, isOrthogonal, isWeakOrthogonal ) where import List (nub) import Rewriting.Position (eps, positions, (|>), replaceTerm) import Rewriting.Rules import Rewriting.Substitution (applySubst) import Rewriting.Term (Term, showTerm, isConsTerm) import Rewriting.Unification (unify) -- --------------------------------------------------------------------------- -- Representation of critical pairs -- --------------------------------------------------------------------------- --- A critical pair represented as a pair of terms and parameterized over the --- kind of function symbols, e.g., strings. type CPair f = (Term f, Term f) -- --------------------------------------------------------------------------- -- Pretty-printing of critical pairs -- --------------------------------------------------------------------------- -- \x3008 = LEFT ANGLE BRACKET -- \x3009 = RIGHT ANGLE BRACKET --- Transforms a critical pair into a string representation. showCPair :: (f -> String) -> CPair f -> String showCPair s (l, r) = "\x3008" ++ (showTerm s l) ++ ", " ++ (showTerm s r) ++ "\x3009" --- Transforms a list of critical pairs into a string representation. showCPairs :: (f -> String) -> [CPair f] -> String showCPairs s = unlines . (map (showCPair s)) -- --------------------------------------------------------------------------- -- Computation of critical pairs -- --------------------------------------------------------------------------- --- Returns the critical pairs of a term rewriting system. cPairs :: TRS f -> [CPair f] cPairs trs = let trs' = maybe trs (\v -> renameTRSVars (v + 1) trs) (maxVarInTRS trs) in nub [(applySubst sub r1, replaceTerm (applySubst sub l1) p (applySubst sub r2)) | rule1@(l1, r1) <- trs', p <- positions l1, let l1p = l1 |> p, isConsTerm l1p, rule2@(l2, r2) <- trs, (Right sub) <- [unify [(l1p, l2)]], (p /= eps) || (not (isVariantOf rule1 rule2))] -- --------------------------------------------------------------------------- -- Functions for term rewriting systems and critical pairs -- --------------------------------------------------------------------------- --- Checks whether a term rewriting system is orthogonal. isOrthogonal :: TRS _ -> Bool isOrthogonal trs = (isLeftLinear trs) && (null (cPairs trs)) --- Checks whether a term rewriting system is weak-orthogonal. isWeakOrthogonal :: TRS _ -> Bool isWeakOrthogonal trs = (isLeftLinear trs) && (all (uncurry (==)) (cPairs trs))curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Rewriting/DefinitionalTree.curry000066400000000000000000000353131305333611600275220ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for representation and computation of definitional trees and --- representation of the reduction strategy phi. --- --- @author Jan-Hendrik Matthes --- @version August 2016 --- @category algorithm ------------------------------------------------------------------------------ module Rewriting.DefinitionalTree ( DefTree (..) , dtRoot, dtPattern, hasDefTree, selectDefTrees, fromDefTrees, idtPositions , defTrees, defTreesL, loDefTrees, phiRStrategy, dotifyDefTree, writeDefTree ) where import Function (on, both) import List import Maybe (listToMaybe, catMaybes) import Rewriting.Position (Pos, eps, positions, (.>), (|>), replaceTerm) import Rewriting.Rules import Rewriting.Strategy (RStrategy) import Rewriting.Substitution (applySubst) import Rewriting.Term import Rewriting.Unification (unify, unifiable) import State -- --------------------------------------------------------------------------- -- Representation of definitional trees -- --------------------------------------------------------------------------- --- Representation of a definitional tree, parameterized over the kind of --- function symbols, e.g., strings. --- --- @cons Leaf r - The leaf with rule `r`. --- @cons Branch pat p dts - The branch with pattern `pat`, inductive position --- `p` and definitional subtrees `dts`. --- @cons Or pat dts - The or node with pattern `pat` and definitional --- subtrees `dts`. data DefTree f = Leaf (Rule f) | Branch (Term f) Pos [DefTree f] | Or (Term f) [DefTree f] -- --------------------------------------------------------------------------- -- Functions for definitional trees -- --------------------------------------------------------------------------- --- Returns the root symbol (variable or constructor) of a definitional tree. dtRoot :: DefTree f -> Either VarIdx f dtRoot (Leaf r) = rRoot r dtRoot (Branch pat _ _) = tRoot pat dtRoot (Or pat _) = tRoot pat --- Returns the pattern of a definitional tree. dtPattern :: DefTree f -> Term f dtPattern (Leaf (l, _)) = l dtPattern (Branch pat _ _) = pat dtPattern (Or pat _) = pat --- Checks whether a term has a definitional tree with the same constructor --- pattern in the given list of definitional trees. hasDefTree :: [DefTree f] -> Term f -> Bool hasDefTree dts t = any ((eqConsPattern t) . dtPattern) dts --- Returns a list of definitional trees with the same constructor pattern for --- a term from the given list of definitional trees. selectDefTrees :: [DefTree f] -> Term f -> [DefTree f] selectDefTrees dts t = filter ((eqConsPattern t) . dtPattern) dts --- Returns the definitional tree with the given index from the given list of --- definitional trees or the provided default definitional tree if the given --- index is not in the given list of definitional trees. fromDefTrees :: DefTree f -> Int -> [DefTree f] -> DefTree f fromDefTrees dt _ [] = dt fromDefTrees dt n dts@(_:_) | (n >= 0) && (n < (length dts)) = dts !! n | otherwise = dt --- Returns a list of all inductive positions in a term rewriting system. idtPositions :: TRS _ -> [Pos] idtPositions [] = [] idtPositions trs@((l, _):_) = case l of (TermVar _) -> [] (TermCons _ ts) -> [[i] | i <- [1..(length ts)], all (isDemandedAt i) trs] --- Returns a list of definitional trees for a term rewriting system. defTrees :: TRS f -> [DefTree f] defTrees = (concatMap defTreesS) . (groupBy eqCons) . (sortBy eqCons) where eqCons :: Rule f -> Rule f -> Bool eqCons = on eqConsPattern fst --- Returns a list of definitional trees for a list of term rewriting systems. defTreesL :: [TRS f] -> [DefTree f] defTreesL = defTrees . concat --- Returns a list of definitional trees for a term rewriting system, whose --- rules have the same constructor pattern. defTreesS :: TRS f -> [DefTree f] defTreesS [] = [] defTreesS trs@((l, _):_) = case l of (TermVar _) -> [] (TermCons c ts) -> let arity = length ts pat = TermCons c (map TermVar [0..(arity - 1)]) pss = permutations (idtPositions trs) in catMaybes [defTreesS' arity trs ps pat | ps <- pss] --- Returns a definitional tree for a term rewriting system, whose rules have --- the same constructor pattern, with the given list of inductive positions, --- the given pattern and the given next possible variable or `Nothing` if no --- such definitional tree exists. defTreesS' :: VarIdx -> TRS f -> [Pos] -> Term f -> Maybe (DefTree f) defTreesS' _ [] [] _ = Nothing defTreesS' v [r] [] pat = mkLeaf v pat r defTreesS' v trs@(_:_:_) [] pat = mkOr v pat (partition (isDemandedAt 1) trs) defTreesS' v trs (p:ps) pat = Just (Branch pat p dts) where nls = nub [normalizeTerm (l |> p) | (l, _) <- trs] ts = map (renameTermVars v) nls pats = [replaceTerm pat p t | t <- ts] dts = catMaybes [defTreesS' v' (selectRules v' pat') ps pat' | pat' <- pats, let v' = max v (maybe 0 (+ 1) (maxVarInTerm pat'))] selectRules :: VarIdx -> Term f -> TRS f selectRules v' t = [r | r@(l, _) <- renameTRSVars v' trs, unifiable [(l, t)]] --- Returns a definitional tree for the given pattern, the given rule and the --- given next possible variable or `Nothing` if no such definitional tree --- exists. mkLeaf :: VarIdx -> Term f -> Rule f -> Maybe (DefTree f) mkLeaf v pat r = case unify [(l, pat)] of (Left _) -> Nothing (Right sub) | pat == (applySubst sub l) -> Just (Leaf (both (applySubst sub) r')) | otherwise -> let (ip:ips) = [p | p <- positions pat, isVarTerm (pat |> p)] pat' = replaceTerm pat ip (l |> ip) v' = max v (maybe 0 (+ 1) (maxVarInTerm pat')) in Just (Branch pat ip (catMaybes [defTreesS' v' [r] ips pat'])) where r'@(l, _) = renameRuleVars v (normalizeRule r) --- Returns a definitional tree for the given pattern, the given pair of term --- rewriting systems and the given next possible variable or `Nothing` if no --- such definitional tree exists. Only the rules in the first term rewriting --- system of the pair have a demanded first argument position. mkOr :: VarIdx -> Term f -> (TRS f, TRS f) -> Maybe (DefTree f) mkOr _ _ ([], []) = Nothing mkOr v pat ([], rs2@(_:_)) = let mdts = map (mkLeaf v pat) rs2 in Just (Or pat (catMaybes mdts)) mkOr v pat (rs1@(_:_), []) = defTreesS' v rs1 (intersect (idtPositions rs1) (varPositions pat)) pat mkOr v pat (rs1@(_:_), rs2@(_:_)) = let vps = varPositions pat mdts = [defTreesS' v rs (intersect (idtPositions rs) vps) pat | rs <- [rs1, rs2]] in Just (Or pat (catMaybes mdts)) --- Returns a list of all variable argument positions in a term. varPositions :: Term _ -> [Pos] varPositions (TermVar _) = [] varPositions (TermCons _ ts) = [[i] | i <- [1..(length ts)], isVarTerm (ts !! (i - 1))] -- --------------------------------------------------------------------------- -- Functions for the reduction strategy phi -- --------------------------------------------------------------------------- --- Returns the position and the definitional trees from the given list of --- definitional trees for the leftmost outermost defined constructor in a --- term or `Nothing` if no such pair exists. loDefTrees :: [DefTree f] -> Term f -> Maybe (Pos, [DefTree f]) loDefTrees [] _ = Nothing loDefTrees dts@(_:_) t = listToMaybe (loDefTrees' eps t) where loDefTrees' :: Pos -> Term f -> [(Pos, [DefTree f])] loDefTrees' _ (TermVar _) = [] loDefTrees' p c@(TermCons _ ts) | hasDefTree dts c = [(p, selectDefTrees dts c)] | otherwise = [lp | (p', t') <- zip [1..] ts, lp <- loDefTrees' (p .> [p']) t'] --- The reduction strategy phi. It uses the definitional tree with the given --- index for all constructor terms if possible or at least the first one. phiRStrategy :: Int -> RStrategy _ phiRStrategy n trs t = let dts = defTrees trs in case loDefTrees dts t of Nothing -> [] (Just (_, [])) -> [] (Just (p, dts'@(dt:_))) -> case phiRStrategy' n dts (t |> p) (fromDefTrees dt n dts') of Nothing -> [] (Just p') -> [p .> p'] --- Returns the position for the reduction strategy phi where a term should be --- reduced according to the given definitional tree or `Nothing` if no such --- position exists. It uses the definitional tree with the given index for --- all constructor terms if possible or at least the first one. phiRStrategy' :: Int -> [DefTree f] -> Term f -> DefTree f -> Maybe Pos phiRStrategy' _ _ t (Leaf (l, _)) | unifiable [(l', t)] = Just eps | otherwise = Nothing where l' = maybe l (\v -> renameTermVars (v + 1) l) (maxVarInTerm t) phiRStrategy' _ _ (TermVar _) (Branch _ _ _) = Nothing phiRStrategy' n dts t@(TermCons _ _) (Branch _ p dts') = case t |> p of (TermVar _) -> Nothing tp@(TermCons _ _) -> case selectDefTrees dts tp of [] -> case find (\dt -> eqConsPattern tp ((dtPattern dt) |> p)) dts' of Nothing -> Nothing (Just dt) -> phiRStrategy' n dts t dt x@(dt:_) -> case phiRStrategy' n dts tp (fromDefTrees dt n x) of Nothing -> Nothing (Just p') -> Just (p .> p') phiRStrategy' _ _ _ (Or _ _) = Nothing -- --------------------------------------------------------------------------- -- Graphical representation of definitional trees -- --------------------------------------------------------------------------- --- A node represented as a tuple of an integer, a possible inductive position --- and a term and parameterized over the kind of function symbols, e.g., --- strings. type Node f = (Int, Maybe Pos, Term f) --- An edge represented as a tuple of a boolean to distinguish between branch --- (`False`) and rule (`True`) edges, a start node and an end node and --- parameterized over the kind of function symbols, e.g., strings. type Edge f = (Bool, Node f, Node f) --- A graph represented as a tuple of nodes and edges and parameterized over --- the kind of function symbols, e.g., strings. type Graph f = ([Node f], [Edge f]) --- Transforms a definitional tree into a graph representation. toGraph :: DefTree f -> Graph f toGraph dt = fst (fst (runState (toGraph' dt) 0)) where toGraph' :: DefTree f -> State Int (Graph f, Node f) toGraph' (Leaf (l, r)) = newIdx `bindS` (\i -> let n = (i, Nothing, l) in (mapS (ruleEdge n) [r]) `bindS` (addNode n)) toGraph' (Branch pat p dts) = newIdx `bindS` (\i -> let n = (i, Just p, pat) in (mapS (branchEdge n) dts) `bindS` (addNode n)) toGraph' (Or pat dts) = newIdx `bindS` (\i -> let n = (i, Nothing, pat) in (mapS (branchEdge n) dts) `bindS` (addNode n)) addNode :: Node f -> [Graph f] -> State Int (Graph f, Node f) addNode n gs = let (ns, es) = unzip gs in returnS ((n:(concat ns), concat es), n) branchEdge :: Node f -> DefTree f -> State Int (Graph f) branchEdge n1 dt' = (toGraph' dt') `bindS` (\((ns, es), n2) -> returnS (ns, (False, n1, n2):es)) ruleEdge :: Node f -> Term f -> State Int (Graph f) ruleEdge n1 t = newIdx `bindS` (\i -> let n = (i, Nothing, t) in returnS ([n], [(True, n1, n)])) newIdx :: State Int Int newIdx = getS `bindS` (\i -> (putS (i + 1)) `bindS_` (returnS i)) --- Transforms a term into a string representation and surrounds the subterm --- at the given position with the html `` and `` tags. showTermWithPos :: (f -> String) -> (Maybe Pos, Term f) -> String showTermWithPos s = showTP False where showTerm' :: Bool -> Term f -> String showTerm' _ (TermVar v) = showVarIdx v showTerm' b (TermCons c ts) = case ts of [] -> s c [l, r] -> parensIf b ((showTerm' True l) ++ " " ++ (s c) ++ " " ++ (showTerm' True r)) _ -> (s c) ++ "(" ++ (intercalate "," (map (showTerm' False) ts)) ++ ")" showTP :: Bool -> (Maybe Pos, Term f) -> String showTP b (Nothing, t) = showTerm' b t showTP b (Just [], t) = "" ++ (showTerm' b t) ++ "" showTP _ (Just (_:_), TermVar v) = showVarIdx v showTP b (Just (p:ps), TermCons c ts) = case [(mp, t) | (i, t) <- zip [1..] ts, let mp = if i == p then (Just ps) else Nothing] of [] -> s c [l, r] -> parensIf b ((showTP True l) ++ " " ++ (s c) ++ " " ++ (showTP True r)) ts' -> (s c) ++ "(" ++ (intercalate "," (map (showTP False) ts')) ++ ")" --- Transforms a definitional tree into a graphical representation by using --- the *DOT graph description language*. dotifyDefTree :: (f -> String) -> DefTree f -> String dotifyDefTree s dt = "digraph DefinitionalTree {\n\t" ++ "node [fontname=Helvetica,fontsize=10,shape=box];\n" ++ (unlines (map showNode ns)) ++ "\tedge [arrowhead=none];\n" ++ (unlines (map showEdge es)) ++ "}" where (ns, es) = toGraph dt showNode :: Node _ -> String showNode (n, p, t) = "\t" ++ (showVarIdx n) ++ " [label=<" ++ (showTermWithPos s (p, t)) ++ ">];" showEdge :: Edge _ -> String showEdge (b, (n1, _, _), (n2, _, _)) = let opts = if b then " [arrowhead=normal];" else ";" in "\t" ++ (showVarIdx n1) ++ " -> " ++ (showVarIdx n2) ++ opts --- Writes the graphical representation of a definitional tree with the --- *DOT graph description language* to a file with the given filename. writeDefTree :: (f -> String) -> DefTree f -> String -> IO () writeDefTree s dt fn = writeFile fn (dotifyDefTree s dt) -- --------------------------------------------------------------------------- -- Definition of helper functions -- --------------------------------------------------------------------------- --- Encloses a string in parenthesis if the given condition is true. parensIf :: Bool -> String -> String parensIf b s = if b then "(" ++ s ++ ")" else scurry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Rewriting/Files.curry000066400000000000000000000203271305333611600253360ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library to read and transform a curry program into an equivalent --- representation, where every function gets assigned the corresponding term --- rewriting system and every type has a corresponding type declaration. --- --- @author Jan-Hendrik Matthes --- @version August 2016 --- @category algorithm ------------------------------------------------------------------------------ module Rewriting.Files ( TRSData, TypeData, RWData , showQName, readQName, condQName, condTRS, readCurryProgram, fromCurryProg , fromFuncDecl, fromRule, fromLiteral, fromPattern, fromRhs, fromExpr ) where import AbstractCurry.Files (tryReadCurryFile) import AbstractCurry.Types import FiniteMap (FM, listToFM) import Rewriting.Rules (Rule, TRS, rCons) import Rewriting.Substitution import Rewriting.Term (Term (..), tConst) -- --------------------------------------------------------------------------- -- Representation of term rewriting system data and type data -- --------------------------------------------------------------------------- --- Mappings from a function name to the corresponding term rewriting system --- represented as a finite map from qualified names to term rewriting --- systems. type TRSData = FM QName (TRS QName) --- Information about types represented as a list of type declarations. type TypeData = [CTypeDecl] --- Representation of term rewriting system data and type data as a pair. type RWData = (TRSData, TypeData) -- --------------------------------------------------------------------------- -- Pretty-printing and reading of qualified names -- --------------------------------------------------------------------------- --- Transforms a qualified name into a string representation. showQName :: QName -> String showQName (mn, fn) | null mn = fn | otherwise = mn ++ "." ++ fn --- Transforms a string into a qualified name. readQName :: String -> QName readQName s = case break (== '.') s of qn@(_, []) -> qn (mn, _:fn) -> (mn, fn) -- --------------------------------------------------------------------------- -- Functions for transforming (abstract) curry programs -- --------------------------------------------------------------------------- --- Returns the qualified name for an `if-then-else`-constructor. condQName :: QName condQName = pre "_if_" --- Returns the term rewriting system for an `if-then-else`-function. condTRS :: TRS QName condTRS = let tTrue = tConst (pre "True") tFalse = tConst (pre "False") in [(TermCons condQName [tTrue, TermVar 0, TermVar 1], TermVar 0), (TermCons condQName [tFalse, TermVar 0, TermVar 1], TermVar 1)] --- Tries to read and transform a curry program into an equivalent --- representation, where every function gets assigned the corresponding term --- rewriting system and every type has a corresponding type declaration. readCurryProgram :: String -> IO (Either String RWData) readCurryProgram fn = do res <- tryReadCurryFile fn case res of (Left e) -> return (Left e) (Right cp) -> return (Right (fromCurryProg cp)) --- Transforms an abstract curry program into an equivalent representation, --- where every function gets assigned the corresponding term rewriting system --- and every type has a corresponding type declaration. fromCurryProg :: CurryProg -> RWData fromCurryProg (CurryProg _ _ ts fs _) = (listToFM (<) (map fromFuncDecl fs), ts) --- Transforms an abstract curry function declaration into a pair with --- function name and corresponding term rewriting system. fromFuncDecl :: CFuncDecl -> (QName, TRS QName) fromFuncDecl (CFunc fn _ _ _ rs) = let (trs, trss) = unzip (map (fromRule fn) rs) cond = if elem condQName (concatMap rCons trs) then condTRS else [] in (fn, trs ++ (concat trss) ++ cond) fromFuncDecl (CmtFunc _ fn a v t rs) = fromFuncDecl (CFunc fn a v t rs) --- Transforms an abstract curry rule for the function with the given name --- into a pair of a rule and a term rewriting system. fromRule :: QName -> CRule -> (Rule QName, TRS QName) fromRule fn (CRule ps rhs) = let (ts, subs) = unzip (map (fromPattern fn) ps) (r, sub, trs) = fromRhs fn rhs sub' = foldr composeSubst emptySubst (sub:subs) in ((TermCons fn ts, applySubst sub' r), trs) --- Transforms an abstract curry literal into a term. fromLiteral :: CLiteral -> Term QName fromLiteral (CIntc i) = tConst ("%i", show i) fromLiteral (CFloatc f) = tConst ("%f", show f) fromLiteral (CCharc c) = tConst ("%c", [c]) fromLiteral (CStringc s) = tConst ("%s", s) --- Transforms an abstract curry pattern for the function with the given name --- into a pair of a term and a substitution. fromPattern :: QName -> CPattern -> (Term QName, Subst QName) fromPattern _ (CPVar (v, _)) = (TermVar v, emptySubst) fromPattern _ (CPLit l) = (fromLiteral l, emptySubst) fromPattern fn (CPComb c ps) = let (ts, subs) = unzip (map (fromPattern fn) ps) in (TermCons c ts, foldr composeSubst emptySubst subs) fromPattern fn (CPAs (v, _) p) = let (t, sub) = fromPattern fn p in (t, extendSubst sub v t) fromPattern fn (CPFuncComb c ps) = let (ts, subs) = unzip (map (fromPattern fn) ps) in (TermCons c ts, foldr composeSubst emptySubst subs) fromPattern fn (CPLazy p) = fromPattern fn p fromPattern fn (CPRecord _ _) = error (pError "fromPattern" "CPRecord" fn) --- Transforms an abstract curry right-hand side of a rule for the function --- with the given name into a tuple of a term, a substitution and a term --- rewriting system. fromRhs :: QName -> CRhs -> (Term QName, Subst QName, TRS QName) fromRhs fn (CSimpleRhs e _) = fromExpr fn e fromRhs fn (CGuardedRhs gs _) = fromGuard fn gs --- Transforms a list of abstract curry guarded expressions for the function --- with the given name into a tuple of a term, a substitution and a term --- rewriting system. fromGuard :: QName -> [(CExpr, CExpr)] -> (Term QName, Subst QName, TRS QName) fromGuard _ [] = (tConst (pre "failed"), emptySubst, []) fromGuard fn ((c, e):gs) = let (ct, cs, ctrs) = fromExpr fn c (et, es, etrs) = fromExpr fn e (gt, gsub, gtrs) = fromGuard fn gs sub = composeSubst cs (composeSubst es gsub) in (TermCons condQName [ct, et, gt], sub, ctrs ++ etrs ++ gtrs) --- Transforms an abstract curry expression for the function with the given --- name into a tuple of a term, a substitution and a term rewriting system. fromExpr :: QName -> CExpr -> (Term QName, Subst QName, TRS QName) fromExpr _ (CVar (v, _)) = (TermVar v, emptySubst, []) fromExpr _ (CLit l) = (fromLiteral l, emptySubst, []) fromExpr _ (CSymbol s) = (tConst s, emptySubst, []) fromExpr fn (CApply fe e) = let (ft, fs, ftrs) = fromExpr fn fe (et, es, etrs) = fromExpr fn e sub = composeSubst fs es in case ft of (TermVar _) -> error "fromExpr: Argument is not a function!" (TermCons c ts) -> (TermCons c (ts ++ [et]), sub, ftrs ++ etrs) fromExpr fn (CLambda _ _) = error (pError "fromExpr" "CLambda" fn) fromExpr fn (CLetDecl _ _) = error (pError "fromExpr" "CLetDecl" fn) fromExpr fn (CDoExpr _) = error (pError "fromExpr" "CDoExpr" fn) fromExpr fn (CListComp _ _) = error (pError "fromExpr" "CListComp" fn) fromExpr fn (CCase _ _ _) = error (pError "fromExpr" "CCase" fn) fromExpr fn (CTyped e _) = fromExpr fn e fromExpr fn (CRecConstr _ _) = error (pError "fromExpr" "CRecConstr" fn) fromExpr fn (CRecUpdate _ _) = error (pError "fromExpr" "CRecUpdate" fn) -- --------------------------------------------------------------------------- -- Definition of helper functions -- --------------------------------------------------------------------------- --- Error message for the given function and the feature, that is not --- supported within the given abstract curry function. pError :: String -> String -> QName -> String pError fn f acf = let fn' = if null fn then "" else fn ++ ": " f' = if null f then "Feature" else f in case showQName acf of [] -> fn' ++ f' ++ " currently not supported!" x@(_:_) -> fn' ++ f' ++ " in " ++ x ++ " currently not supported!"curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Rewriting/Narrowing.curry000066400000000000000000000434301305333611600262420ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for representation and computation of narrowings on first-order --- terms and representation of narrowing strategies. --- --- @author Jan-Hendrik Matthes --- @version November 2016 --- @category algorithm ------------------------------------------------------------------------------ module Rewriting.Narrowing ( NStrategy, Narrowing (..), NarrowingTree (..), NOptions (..) , defaultNOptions, showNarrowing, stdNStrategy, imNStrategy, omNStrategy , loNStrategy, lazyNStrategy, wnNStrategy, narrowBy, narrowByL, narrowingBy , narrowingByL, narrowingTreeBy, narrowingTreeByL, solveEq, solveEqL , dotifyNarrowingTree, writeNarrowingTree ) where import FiniteMap (eltsFM) import Maybe (fromMaybe, mapMaybe) import List (maximum) import Rewriting.DefinitionalTree import Rewriting.Position import Rewriting.Rules import Rewriting.Strategy (RStrategy, poRStrategy, reduce) import Rewriting.Substitution import Rewriting.Term import Rewriting.Unification (UnificationError (..), unify, unifiable) import State -- --------------------------------------------------------------------------- -- Representation of narrowing strategies -- --------------------------------------------------------------------------- --- A narrowing strategy represented as a function that takes a term rewriting --- system and a term and returns a list of triples consisting of a position, --- a rule and a substitution, parameterized over the kind of function --- symbols, e.g., strings. type NStrategy f = TRS f -> Term f -> [(Pos, Rule f, Subst f)] -- --------------------------------------------------------------------------- -- Representation of narrowings on first-order terms -- --------------------------------------------------------------------------- --- Representation of a narrowing on first-order terms, parameterized over the --- kind of function symbols, e.g., strings. --- --- @cons NTerm t - The narrowed term `t`. --- @cons NStep t p sub n - The narrowing of term `t` at position `p` with --- substitution `sub` to narrowing `n`. data Narrowing f = NTerm (Term f) | NStep (Term f) Pos (Subst f) (Narrowing f) -- --------------------------------------------------------------------------- -- Representation of narrowing trees for first-order terms -- --------------------------------------------------------------------------- --- Representation of a narrowing tree for first-order terms, parameterized --- over the kind of function symbols, e.g., strings. --- --- @cons NTree t ns - The narrowing of term `t` to a new term with a list of --- narrowing steps `ns`. data NarrowingTree f = NTree (Term f) [(Pos, Subst f, NarrowingTree f)] -- --------------------------------------------------------------------------- -- Representation of narrowing options for solving term equations -- --------------------------------------------------------------------------- --- Representation of narrowing options for solving term equations, --- parameterized over the kind of function symbols, e.g., strings. --- --- @field normalize - Indicates whether a term should be normalized before --- computing further narrowing steps. --- @field rStrategy - The reduction strategy to normalize a term. data NOptions f = NOptions { normalize :: Bool, rStrategy :: RStrategy f } --- The default narrowing options. defaultNOptions :: NOptions _ defaultNOptions = NOptions { normalize = False, rStrategy = poRStrategy } -- --------------------------------------------------------------------------- -- Pretty-printing of narrowings on first-order terms -- --------------------------------------------------------------------------- -- \x2192 = RIGHTWARDS ARROW --- Transforms a narrowing into a string representation. showNarrowing :: (f -> String) -> Narrowing f -> String showNarrowing s (NTerm t) = showTerm s t showNarrowing s (NStep t p sub n) = (showTerm s t) ++ "\n\x2192" ++ "[" ++ (showPos p) ++ ", " ++ (showSubst s (restrictSubst sub (tVars t))) ++ "] " ++ (showNarrowing s n) -- --------------------------------------------------------------------------- -- Definition of common narrowing strategies -- --------------------------------------------------------------------------- --- The standard narrowing strategy. stdNStrategy :: NStrategy _ stdNStrategy trs t = [(p, rule, sub) | p <- positions t, let tp = t |> p, isConsTerm tp, rule@(l, _) <- trs, (Right sub) <- [unify [(tp, l)]]] --- The innermost narrowing strategy. imNStrategy :: NStrategy _ imNStrategy trs t = [(p, rule, sub) | p <- positions t, let tp = t |> p, isPattern trs tp, rule@(l, _) <- trs, (Right sub) <- [unify [(tp, l)]]] --- The outermost narrowing strategy. omNStrategy :: NStrategy _ omNStrategy trs t = let ns = stdNStrategy trs t in [n | n@(p, _, _) <- ns, all (\p' -> not (above p' p)) [p' | (p', _, _) <- ns, p' /= p]] --- The leftmost outermost narrowing strategy. loNStrategy :: NStrategy _ loNStrategy trs t = let ns = stdNStrategy trs t in [n | n@(p, _, _) <- ns, all (\p' -> not ((above p' p) || (leftOf p' p))) [p' | (p', _, _) <- ns, p' /= p]] --- The lazy narrowing strategy. lazyNStrategy :: NStrategy _ lazyNStrategy trs t = let lps = lazyPositions trs t in filter (\(p, _, _) -> elem p lps) (stdNStrategy trs t) --- Returns a list of all lazy positions in a term according to the given term --- rewriting system. lazyPositions :: TRS f -> Term f -> [Pos] lazyPositions _ (TermVar _) = [] lazyPositions trs t@(TermCons _ ts) | isRedex trs t = if null rs then lps else eps:lps | otherwise = [i:p | (i, t') <- zip [1..] ts, p <- lazyPositions trs t'] where ftrs = filter ((eqConsPattern t) . fst) trs rs = [r | r@(l, _) <- ftrs, unifiable [(t, l)]] dps = [i | (i, _) <- zip [1..] ts, any (isDemandedAt i) ftrs] lps = [i:p | i <- dps, p <- lazyPositions trs (ts !! (i - 1))] --- The weakly needed narrowing strategy. wnNStrategy :: NStrategy _ wnNStrategy trs t = let dts = defTrees trs v = fromMaybe 0 (minVarInTRS trs) in case loDefTrees dts t of Nothing -> [] (Just (_, [])) -> [] (Just (p, dt:_)) -> [(p .> q, r, sub) | (q, r, sub) <- wnNStrategy' dts v (t |> p) dt] --- Returns the narrowing steps for the weakly needed narrowing strategy --- according to the given definitional tree and the given next possible --- variable. wnNStrategy' :: [DefTree f] -> VarIdx -> Term f -> DefTree f -> [(Pos, Rule f, Subst f)] wnNStrategy' _ v t (Leaf r) = let rule@(l, _) = renameRuleVars v (normalizeRule r) in [(eps, rule, sub) | (Right sub) <- [unify [(t, l)]]] wnNStrategy' dts v t (Branch pat p dts') = case selectDefTrees dts (t |> p) of [] -> concatMap (wnNStrategy' dts v t) (filterDTS dts') (dt:_) -> case unify [(t, renameTermVars v (normalizeTerm pat))] of (Left _) -> [] (Right tau) -> let tau' = restrictSubst tau (tVars t) t' = applySubst tau' t v' = max v (maybe 0 (+ 1) (maxVarInTerm t')) in [(p .> p', rule, composeSubst sub tau') | (p', rule, sub) <- wnNStrategy' dts v' (t' |> p) dt] where filterDTS :: [DefTree f] -> [DefTree f] filterDTS = filter (\dt -> let dtp = renameTermVars v (dtPattern dt) in unifiable [(t, dtp)]) wnNStrategy' dts v t (Or _ dts') = concatMap (wnNStrategy' dts v t) dts' -- --------------------------------------------------------------------------- -- Functions for narrowings on first-order terms -- --------------------------------------------------------------------------- --- Narrows a term with the given strategy and term rewriting system by the --- given number of steps. narrowBy :: NStrategy f -> TRS f -> Int -> Term f -> [(Subst f, Term f)] narrowBy s trs n t | n <= 0 = [] | otherwise = let v = maybe 0 (+ 1) (maxVarInTerm t) in narrowBy' v emptySubst s trs n t --- Narrows a term with the given strategy and list of term rewriting systems --- by the given number of steps. narrowByL :: NStrategy f -> [TRS f] -> Int -> Term f -> [(Subst f, Term f)] narrowByL s trss = narrowBy s (concat trss) --- Narrows a term with the given strategy, the given term rewriting system, --- the already existing substitution and the given next possible variable by --- the given number of steps. narrowBy' :: VarIdx -> Subst f -> NStrategy f -> TRS f -> Int -> Term f -> [(Subst f, Term f)] narrowBy' v sub s trs n t | n <= 0 = [(sub, t)] | otherwise = case s (renameTRSVars v (normalizeTRS trs)) t of [] -> [(sub, t)] ns@(_:_) -> concatMap combine ns where combine :: (Pos, Rule f, Subst f) -> [(Subst f, Term f)] combine (p, (_, r), sub') = let t' = applySubst sub' (replaceTerm t p r) rsub' = restrictSubst sub' (tVars t) v' = case mapMaybe maxVarInTerm (eltsFM rsub') of [] -> v vs@(_:_) -> (maximum vs) + 1 in narrowBy' v' (composeSubst rsub' sub) s trs (n - 1) t' --- Returns a list of narrowings for a term with the given strategy, the given --- term rewriting system and the given number of steps. narrowingBy :: NStrategy f -> TRS f -> Int -> Term f -> [Narrowing f] narrowingBy s trs n t | n <= 0 = [] | otherwise = let v = maybe 0 (+ 1) (maxVarInTerm t) in narrowingBy' v emptySubst s trs n t --- Returns a list of narrowings for a term with the given strategy, the given --- list of term rewriting systems and the given number of steps. narrowingByL :: NStrategy f -> [TRS f] -> Int -> Term f -> [Narrowing f] narrowingByL s trss = narrowingBy s (concat trss) --- Returns a list of narrowings for a term with the given strategy, the given --- term rewriting system, the already existing substitution, the given next --- possible variable and the given number of steps. narrowingBy' :: VarIdx -> Subst f -> NStrategy f -> TRS f -> Int -> Term f -> [Narrowing f] narrowingBy' v sub s trs n t | n <= 0 = [NTerm t] | otherwise = case s (renameTRSVars v (normalizeTRS trs)) t of [] -> [NTerm t] ns@(_:_) -> concatMap combine ns where combine :: (Pos, Rule f, Subst f) -> [Narrowing f] combine (p, (_, r), sub') = let t' = applySubst sub' (replaceTerm t p r) rsub' = restrictSubst sub' (tVars t) phi = composeSubst rsub' sub v' = case mapMaybe maxVarInTerm (eltsFM rsub') of [] -> v vs@(_:_) -> (maximum vs) + 1 in map (NStep t p phi) (narrowingBy' v' phi s trs (n - 1) t') --- Returns a narrowing tree for a term with the given strategy, the given --- term rewriting system and the given number of steps. narrowingTreeBy :: NStrategy f -> TRS f -> Int -> Term f -> NarrowingTree f narrowingTreeBy s trs n t | n <= 0 = NTree t [] | otherwise = let v = maybe 0 (+ 1) (maxVarInTerm t) in narrowingTreeBy' v emptySubst s trs n t --- Returns a narrowing tree for a term with the given strategy, the given --- list of term rewriting systems and the given number of steps. narrowingTreeByL :: NStrategy f -> [TRS f] -> Int -> Term f -> NarrowingTree f narrowingTreeByL s trss = narrowingTreeBy s (concat trss) --- Returns a narrowing tree for a term with the given strategy, the given --- term rewriting system, the already existing substitution, the given next --- possible variable and the given number of steps. narrowingTreeBy' :: VarIdx -> Subst f -> NStrategy f -> TRS f -> Int -> Term f -> NarrowingTree f narrowingTreeBy' v sub s trs n t | n <= 0 = NTree t [] | otherwise = NTree t (map combine (s trs' t)) where trs' = renameTRSVars v (normalizeTRS trs) combine :: (Pos, Rule f, Subst f) -> (Pos, Subst f, NarrowingTree f) combine (p, (_, r), sub') = let t' = applySubst sub' (replaceTerm t p r) rsub' = restrictSubst sub' (tVars t) phi = composeSubst rsub' sub v' = case mapMaybe maxVarInTerm (eltsFM rsub') of [] -> v vs@(_:_) -> (maximum vs) + 1 in (p, phi, narrowingTreeBy' v' phi s trs (n - 1) t') --- Solves a term equation with the given strategy, the given term rewriting --- system and the given options. The term has to be of the form --- `TermCons c [l, r]` with `c` being a constructor like `=`. The term `l` --- and the term `r` are the left-hand side and the right-hand side of the --- term equation. solveEq :: NOptions f -> NStrategy f -> TRS f -> Term f -> [Subst f] solveEq _ _ _ (TermVar _) = [] solveEq opts s trs t@(TermCons _ ts) = case ts of [_, _] -> let vs = tVars t v = maybe 0 (+ 1) (maxVarInTerm t) in map ((flip restrictSubst) vs) (solveEq' opts v emptySubst s trs t) _ -> [] --- Solves a term equation with the given strategy, the given list of term --- rewriting systems and the given options. The term has to be of the form --- `TermCons c [l, r]` with `c` being a constructor like `=`. The term `l` --- and the term `r` are the left-hand side and the right-hand side of the --- term equation. solveEqL :: NOptions f -> NStrategy f -> [TRS f] -> Term f -> [Subst f] solveEqL opts s trss = solveEq opts s (concat trss) --- Solves a term equation with the given strategy, the given term rewriting --- system, the already existing substitution, the given next possible --- variable and the given options. The term has to be of the form --- `TermCons c [l, r]` with `c` being a constructor like `=`. The term `l` --- and the term `r` are the left-hand side and the right-hand side of the --- term equation. solveEq' :: NOptions f -> VarIdx -> Subst f -> NStrategy f -> TRS f -> Term f -> [Subst f] solveEq' _ _ _ _ _ (TermVar _) = [] solveEq' opts v sub s trs t@(TermCons _ ts) = case ts of [_, _] -> case unify [(l, r)] of (Left (Clash t1 t2)) | (isRedex trs t1) || (isRedex trs t2) -> concatMap solve (s trs' nt) | otherwise -> [] (Left (OccurCheck _ _)) -> [] (Right sub') -> [composeSubst sub' sub] _ -> [] where trs' = renameTRSVars v (normalizeTRS trs) nt@(TermCons _ [l, r]) = if (normalize opts) then reduce (rStrategy opts) trs t else t solve :: (Pos, Rule f, Subst f) -> [Subst f] solve (p, (_, r'), sub') = let t' = applySubst sub' (replaceTerm nt p r') rsub' = restrictSubst sub' (tVars nt) v' = case mapMaybe maxVarInTerm (eltsFM rsub') of [] -> v vs@(_:_) -> (maximum vs) + 1 in solveEq' opts v' (composeSubst rsub' sub) s trs t' -- --------------------------------------------------------------------------- -- Graphical representation of narrowing trees -- --------------------------------------------------------------------------- --- A node represented as a pair of an integer and a term and parameterized --- over the kind of function symbols, e.g., strings. type Node f = (Int, Term f) --- An edge represented as a tuple of a start node, a substitution and an end --- node and parameterized over the kind of function symbols, e.g., strings. type Edge f = (Node f, Subst f, Node f) --- A graph represented as a pair of nodes and edges and parameterized over --- the kind of function symbols, e.g., strings. type Graph f = ([Node f], [Edge f]) --- Transforms a narrowing tree into a graph representation. toGraph :: NarrowingTree f -> Graph f toGraph ng = fst (fst (runState (toGraph' ng) 0)) where toGraph' :: NarrowingTree f -> State Int (Graph f, Node f) toGraph' (NTree t ngs) = newIdx `bindS` (\i -> let n = (i, t) in (mapS (edge n) ngs) `bindS` (\gs -> let (ns, es) = unzip gs in returnS ((n:(concat ns), concat es), n))) edge :: Node f -> (Pos, Subst f, NarrowingTree f) -> State Int (Graph f) edge n1 (_, sub, ng') = (toGraph' ng') `bindS` (\((ns, es), n2) -> returnS (ns, (n1, sub, n2):es)) newIdx :: State Int Int newIdx = getS `bindS` (\i -> (putS (i + 1)) `bindS_` (returnS i)) --- Transforms a narrowing tree into a graphical representation by using the --- *DOT graph description language*. dotifyNarrowingTree :: (f -> String) -> NarrowingTree f -> String dotifyNarrowingTree s ng = "digraph NarrowingTree {\n\t" ++ "node [fontname=Helvetica,fontsize=10,shape=box];\n" ++ (unlines (map showNode ns)) ++ "\tedge [fontname=Helvetica,fontsize=10];\n" ++ (unlines (map showEdge es)) ++ "}" where (ns, es) = toGraph ng showNode :: Node _ -> String showNode (n, t) = "\t" ++ (showVarIdx n) ++ " [label=\"" ++ (showTerm s t) ++ "\"];" showEdge :: Edge _ -> String showEdge ((n1, t), sub, (n2, _)) = "\t" ++ (showVarIdx n1) ++ " -> " ++ (showVarIdx n2) ++ " [label=\"" ++ (showSubst s (restrictSubst sub (tVars t))) ++ "\"];" --- Writes the graphical representation of a narrowing tree with the --- *DOT graph description language* to a file with the given filename. writeNarrowingTree :: (f -> String) -> NarrowingTree f -> String -> IO () writeNarrowingTree s ng fn = writeFile fn (dotifyNarrowingTree s ng) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Rewriting/Position.curry000066400000000000000000000070121305333611600260740ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for representation of positions in first-order terms. --- --- @author Jan-Hendrik Matthes --- @version November 2016 --- @category algorithm ------------------------------------------------------------------------------ {-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-} module Rewriting.Position ( Pos , showPos, eps, above, below, leftOf, rightOf, disjoint , positions, (.>), (|>), replaceTerm ) where import List (intercalate, isPrefixOf) import Rewriting.Term (Term (..)) -- --------------------------------------------------------------------------- -- Representation of positions in first-order terms -- --------------------------------------------------------------------------- --- A position in a term represented as a list of integers greater than zero. type Pos = [Int] -- --------------------------------------------------------------------------- -- Pretty-printing of positions in first-order terms -- --------------------------------------------------------------------------- -- \x00b7 = MIDDLE DOT -- \x03b5 = GREEK SMALL LETTER EPSILON --- Transforms a position into a string representation. showPos :: Pos -> String showPos [] = "\x03b5" showPos ps@(_:_) = intercalate "\x00b7" (map show ps) -- --------------------------------------------------------------------------- -- Functions for positions in first-order terms -- --------------------------------------------------------------------------- --- The root position of a term. eps :: Pos eps = [] --- Checks whether the first position is above the second position. above :: Pos -> Pos -> Bool above = isPrefixOf --- Checks whether the first position is below the second position. below :: Pos -> Pos -> Bool below = flip above --- Checks whether the first position is left from the second position. leftOf :: Pos -> Pos -> Bool leftOf [] _ = False leftOf (_:_) [] = False leftOf (p:ps) (q:qs) = case compare p q of LT -> True EQ -> leftOf ps qs GT -> False --- Checks whether the first position is right from the second position. rightOf :: Pos -> Pos -> Bool rightOf = flip leftOf --- Checks whether two positions are disjoint. disjoint :: Pos -> Pos -> Bool disjoint p q = not ((above p q) || (below p q)) --- Returns a list of all positions in a term. positions :: Term _ -> [Pos] positions (TermVar _) = [eps] positions (TermCons _ ts) = eps:[i:p | (i, t) <- zip [1..] ts, p <- positions t] --- Concatenates two positions. (.>) :: Pos -> Pos -> Pos (.>) = (++) -- --------------------------------------------------------------------------- -- Functions for subterm selection and term replacement -- --------------------------------------------------------------------------- --- Returns the subterm of a term at the given position if the position exists --- within the term. (|>) :: Term f -> Pos -> Term f t |> [] = t (TermCons _ ts) |> (i:p) = (ts !! (i - 1)) |> p --- Replaces the subterm of a term at the given position with the given term --- if the position exists within the term. replaceTerm :: Term f -> Pos -> Term f -> Term f replaceTerm _ [] s = s replaceTerm t@(TermVar _) (_:_) _ = t replaceTerm t@(TermCons c ts) (i:p) s | (i > 0) && (i <= (length ts)) = TermCons c ts' | otherwise = t where (ts1, ti:ts2) = splitAt (i - 1) ts ts' = ts1 ++ ((replaceTerm ti p s):ts2)curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Rewriting/Rules.curry000066400000000000000000000130341305333611600253630ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for representation of rules and term rewriting systems. --- --- @author Jan-Hendrik Matthes --- @version November 2016 --- @category algorithm ------------------------------------------------------------------------------ module Rewriting.Rules ( Rule, TRS , showRule, showTRS, rRoot, rCons, rVars, maxVarInRule, minVarInRule , maxVarInTRS, minVarInTRS, renameRuleVars, renameTRSVars, normalizeRule , normalizeTRS, isVariantOf, isLeftLinear, isLeftNormal, isRedex, isPattern , isConsBased, isDemandedAt ) where import Function (on, both) import List (union, maximum, minimum) import Maybe (mapMaybe) import Rewriting.Substitution (listToSubst, applySubst) import Rewriting.Term -- --------------------------------------------------------------------------- -- Representation of rules and term rewriting systems -- --------------------------------------------------------------------------- --- A rule represented as a pair of terms and parameterized over the kind of --- function symbols, e.g., strings. type Rule f = (Term f, Term f) --- A term rewriting system represented as a list of rules and parameterized --- over the kind of function symbols, e.g., strings. type TRS f = [Rule f] -- --------------------------------------------------------------------------- -- Pretty-printing of rules and term rewriting systems -- --------------------------------------------------------------------------- -- \x2192 = RIGHTWARDS ARROW --- Transforms a rule into a string representation. showRule :: (f -> String) -> Rule f -> String showRule s (l, r) = (showTerm s l) ++ " \x2192 " ++ (showTerm s r) --- Transforms a term rewriting system into a string representation. showTRS :: (f -> String) -> TRS f -> String showTRS s = unlines . (map (showRule s)) -- --------------------------------------------------------------------------- -- Functions for rules and term rewriting systems -- --------------------------------------------------------------------------- --- Returns the root symbol (variable or constructor) of a rule. rRoot :: Rule f -> Either VarIdx f rRoot (l, _) = tRoot l --- Returns a list without duplicates of all constructors in a rule. rCons :: Rule f -> [f] rCons (l, r) = union (tCons l) (tCons r) --- Returns a list without duplicates of all variables in a rule. rVars :: Rule _ -> [VarIdx] rVars (l, _) = tVars l --- Returns the maximum variable in a rule or `Nothing` if no variable exists. maxVarInRule :: Rule _ -> Maybe VarIdx maxVarInRule (l, _) = maxVarInTerm l --- Returns the minimum variable in a rule or `Nothing` if no variable exists. minVarInRule :: Rule _ -> Maybe VarIdx minVarInRule (l, _) = minVarInTerm l --- Returns the maximum variable in a term rewriting system or `Nothing` if no --- variable exists. maxVarInTRS :: TRS _ -> Maybe VarIdx maxVarInTRS trs = case mapMaybe maxVarInRule trs of [] -> Nothing vs@(_:_) -> Just (maximum vs) --- Returns the minimum variable in a term rewriting system or `Nothing` if no --- variable exists. minVarInTRS :: TRS _ -> Maybe VarIdx minVarInTRS trs = case mapMaybe minVarInRule trs of [] -> Nothing vs@(_:_) -> Just (minimum vs) --- Renames the variables in a rule by the given number. renameRuleVars :: Int -> Rule f -> Rule f renameRuleVars i = both (renameTermVars i) --- Renames the variables in every rule of a term rewriting system by the --- given number. renameTRSVars :: Int -> TRS f -> TRS f renameTRSVars i = map (renameRuleVars i) --- Normalizes a rule by renaming all variables with an increasing order, --- starting from the minimum possible variable. normalizeRule :: Rule f -> Rule f normalizeRule r = let sub = listToSubst (zip (rVars r) (map TermVar [0..])) in both (applySubst sub) r --- Normalizes all rules in a term rewriting system by renaming all variables --- with an increasing order, starting from the minimum possible variable. normalizeTRS :: TRS f -> TRS f normalizeTRS = map normalizeRule --- Checks whether the first rule is a variant of the second rule. isVariantOf :: Rule f -> Rule f -> Bool isVariantOf = on (==) normalizeRule --- Checks whether a term rewriting system is left-linear. isLeftLinear :: TRS _ -> Bool isLeftLinear = all (isLinear . fst) --- Checks whether a term rewriting system is left-normal. isLeftNormal :: TRS _ -> Bool isLeftNormal = all (isNormal . fst) --- Checks whether a term is reducible with some rule --- of the given term rewriting system. isRedex :: TRS f -> Term f -> Bool isRedex trs t = any ((eqConsPattern t) . fst) trs --- Checks whether a term is a pattern, i.e., an root-reducible term --- where the argaccording to the given term rewriting --- system. isPattern :: TRS f -> Term f -> Bool isPattern _ (TermVar _) = False isPattern trs t@(TermCons _ ts) = isRedex trs t && all isVarOrCons ts where isVarOrCons :: Term f -> Bool isVarOrCons (TermVar _) = True isVarOrCons t'@(TermCons _ ts') = not (isRedex trs t') && all isVarOrCons ts' --- Checks whether a term rewriting system is constructor-based. isConsBased :: TRS _ -> Bool isConsBased trs = all ((isPattern trs) . fst) trs --- Checks whether the given argument position of a rule is demanded. Returns --- `True` if the corresponding argument term is a constructor term. isDemandedAt :: Int -> Rule _ -> Bool isDemandedAt _ (TermVar _, _) = False isDemandedAt i (TermCons _ ts, _) = (i > 0) && (i <= (length ts)) && (isConsTerm (ts !! (i - 1)))curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Rewriting/Strategy.curry000066400000000000000000000215561305333611600261030ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for representation and computation of reductions on first-order --- terms and representation of reduction strategies. --- --- @author Jan-Hendrik Matthes --- @version November 2016 --- @category algorithm ------------------------------------------------------------------------------ module Rewriting.Strategy ( RStrategy, Reduction (..) , showReduction, redexes, seqRStrategy, parRStrategy, liRStrategy , loRStrategy, riRStrategy, roRStrategy, piRStrategy, poRStrategy, reduce , reduceL, reduceBy, reduceByL, reduceAt, reduceAtL, reduction, reductionL , reductionBy, reductionByL ) where import List (nub, intercalate, groupBy, sortBy, minimumBy) import Rewriting.Position import Rewriting.Rules (TRS, renameRuleVars, renameTRSVars) import Rewriting.Substitution (applySubst) import Rewriting.Term (Term, showTerm, maxVarInTerm) import Rewriting.Unification (unify) -- --------------------------------------------------------------------------- -- Representation of reduction strategies -- --------------------------------------------------------------------------- --- A reduction strategy represented as a function that takes a term rewriting --- system and a term and returns the redex positions where the term should be --- reduced, parameterized over the kind of function symbols, e.g., strings. type RStrategy f = TRS f -> Term f -> [Pos] -- --------------------------------------------------------------------------- -- Representation of reductions on first-order terms -- --------------------------------------------------------------------------- --- Representation of a reduction on first-order terms, parameterized over the --- kind of function symbols, e.g., strings. --- --- @cons NormalForm t - The normal form with term `t`. --- @cons RStep t ps r - The reduction of term `t` at positions `ps` to --- reduction `r`. data Reduction f = NormalForm (Term f) | RStep (Term f) [Pos] (Reduction f) -- --------------------------------------------------------------------------- -- Pretty-printing of reductions on first-order terms -- --------------------------------------------------------------------------- -- \x2192 = RIGHTWARDS ARROW --- Transforms a reduction into a string representation. showReduction :: (f -> String) -> Reduction f -> String showReduction s (NormalForm t) = showTerm s t showReduction s (RStep t ps r) = (showTerm s t) ++ "\n\x2192" ++ "[" ++ (intercalate "," (map showPos ps)) ++ "] " ++ (showReduction s r) -- --------------------------------------------------------------------------- -- Functions for definition of reduction strategies -- --------------------------------------------------------------------------- --- Returns the redex positions of a term according to the given term --- rewriting system. redexes :: TRS f -> Term f -> [Pos] redexes trs t = let trs' = maybe trs (\v -> renameTRSVars (v + 1) trs) (maxVarInTerm t) in nub [p | p <- positions t, let tp = t |> p, (l, _) <- trs', (Right sub) <- [unify [(l, tp)]], tp == (applySubst sub l)] --- Returns a sequential reduction strategy according to the given ordering --- function. seqRStrategy :: (Pos -> Pos -> Ordering) -> RStrategy _ seqRStrategy cmp trs t = case redexes trs t of [] -> [] ps@(_:_) -> [minimumBy cmp ps] --- Returns a parallel reduction strategy according to the given ordering --- function. parRStrategy :: (Pos -> Pos -> Ordering) -> RStrategy _ parRStrategy cmp trs t = case redexes trs t of [] -> [] ps@(_:_) -> head (groupBy g (sortBy s ps)) where g :: Pos -> Pos -> Bool g p q = (cmp p q) == EQ s :: Pos -> Pos -> Bool s p q = (cmp p q) /= GT -- --------------------------------------------------------------------------- -- Definition of common reduction strategies -- --------------------------------------------------------------------------- --- The leftmost innermost reduction strategy. liRStrategy :: RStrategy _ liRStrategy = seqRStrategy liOrder where liOrder :: Pos -> Pos -> Ordering liOrder p q | p == q = EQ | leftOf p q = LT | below p q = LT | otherwise = GT --- The leftmost outermost reduction strategy. loRStrategy :: RStrategy _ loRStrategy = seqRStrategy loOrder where loOrder :: Pos -> Pos -> Ordering loOrder p q | p == q = EQ | leftOf p q = LT | above p q = LT | otherwise = GT --- The rightmost innermost reduction strategy. riRStrategy :: RStrategy _ riRStrategy = seqRStrategy riOrder where riOrder :: Pos -> Pos -> Ordering riOrder p q | p == q = EQ | rightOf p q = LT | below p q = LT | otherwise = GT --- The rightmost outermost reduction strategy. roRStrategy :: RStrategy _ roRStrategy = seqRStrategy roOrder where roOrder :: Pos -> Pos -> Ordering roOrder p q | p == q = EQ | rightOf p q = LT | above p q = LT | otherwise = GT --- The parallel innermost reduction strategy. piRStrategy :: RStrategy _ piRStrategy = parRStrategy piOrder where piOrder :: Pos -> Pos -> Ordering piOrder p q | p == q = EQ | below p q = LT | above p q = GT | otherwise = EQ --- The parallel outermost reduction strategy. poRStrategy :: RStrategy _ poRStrategy = parRStrategy poOrder where poOrder :: Pos -> Pos -> Ordering poOrder p q | p == q = EQ | above p q = LT | below p q = GT | otherwise = EQ -- --------------------------------------------------------------------------- -- Functions for reductions on first-order terms -- --------------------------------------------------------------------------- --- Reduces a term with the given strategy and term rewriting system. reduce :: RStrategy f -> TRS f -> Term f -> Term f reduce s trs t = case s trs t of [] -> t ps@(_:_) -> reduce s trs (reduceAtL trs ps t) --- Reduces a term with the given strategy and list of term rewriting systems. reduceL :: RStrategy f -> [TRS f] -> Term f -> Term f reduceL s trss = reduce s (concat trss) --- Reduces a term with the given strategy and term rewriting system by the --- given number of steps. reduceBy :: RStrategy f -> TRS f -> Int -> Term f -> Term f reduceBy s trs n t | n <= 0 = t | otherwise = case s trs t of [] -> t ps@(_:_) -> reduceBy s trs (n - 1) (reduceAtL trs ps t) --- Reduces a term with the given strategy and list of term rewriting systems --- by the given number of steps. reduceByL :: RStrategy f -> [TRS f] -> Int -> Term f -> Term f reduceByL s trss = reduceBy s (concat trss) --- Reduces a term with the given term rewriting system at the given redex --- position. reduceAt :: TRS f -> Pos -> Term f -> Term f reduceAt [] _ t = t reduceAt (x:rs) p t = case unify [(l, tp)] of (Left _) -> reduceAt rs p t (Right s) | tp == (applySubst s l) -> replaceTerm t p (applySubst s r) | otherwise -> reduceAt rs p t where tp = t |> p (l, r) = maybe x (\v -> renameRuleVars (v + 1) x) (maxVarInTerm tp) --- Reduces a term with the given term rewriting system at the given redex --- positions. reduceAtL :: TRS f -> [Pos] -> Term f -> Term f reduceAtL _ [] t = t reduceAtL trs (p:ps) t = reduceAtL trs ps (reduceAt trs p t) --- Returns the reduction of a term with the given strategy and term rewriting --- system. reduction :: RStrategy f -> TRS f -> Term f -> Reduction f reduction s trs t = case s trs t of [] -> NormalForm t ps@(_:_) -> RStep t ps (reduction s trs (reduceAtL trs ps t)) --- Returns the reduction of a term with the given strategy and list of term --- rewriting systems. reductionL :: RStrategy f -> [TRS f] -> Term f -> Reduction f reductionL s trss = reduction s (concat trss) --- Returns the reduction of a term with the given strategy, the given term --- rewriting system and the given number of steps. reductionBy :: RStrategy f -> TRS f -> Int -> Term f -> Reduction f reductionBy s trs n t | n <= 0 = NormalForm t | otherwise = case s trs t of [] -> NormalForm t ps@(_:_) -> let t' = reduceAtL trs ps t in RStep t ps (reductionBy s trs (n - 1) t') --- Returns the reduction of a term with the given strategy, the given list of --- term rewriting systems and the given number of steps. reductionByL :: RStrategy f -> [TRS f] -> Int -> Term f -> Reduction f reductionByL s trss = reductionBy s (concat trss)curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Rewriting/Substitution.curry000066400000000000000000000075061305333611600270140ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for representation of substitutions on first-order terms. --- --- @author Jan-Hendrik Matthes --- @version August 2016 --- @category algorithm ------------------------------------------------------------------------------ module Rewriting.Substitution ( Subst , showSubst, emptySubst, extendSubst, listToSubst, lookupSubst, applySubst , applySubstEq, applySubstEqs, restrictSubst, composeSubst ) where import FiniteMap import Function (both) import List (intercalate) import Maybe (fromMaybe) import Rewriting.Term -- --------------------------------------------------------------------------- -- Representation of substitutions on first-order terms -- --------------------------------------------------------------------------- --- A substitution represented as a finite map from variables to terms and --- parameterized over the kind of function symbols, e.g., strings. type Subst f = FM VarIdx (Term f) -- --------------------------------------------------------------------------- -- Pretty-printing of substitutions on first-order terms -- --------------------------------------------------------------------------- -- \x21a6 = RIGHTWARDS ARROW FROM BAR --- Transforms a substitution into a string representation. showSubst :: (f -> String) -> Subst f -> String showSubst s sub = "{" ++ (intercalate "," (map showMapping (fmToList sub))) ++ "}" where showMapping :: (VarIdx, Term f) -> String showMapping (v, t) = (showVarIdx v) ++ " \x21a6 " ++ (showTerm s t) -- --------------------------------------------------------------------------- -- Functions for substitutions on first-order terms -- --------------------------------------------------------------------------- --- The irreflexive order predicate of a substitution. substOrder :: VarIdx -> VarIdx -> Bool substOrder = (<) --- The empty substitution. emptySubst :: Subst _ emptySubst = emptyFM substOrder --- Extends a substitution with a new mapping from the given variable to the --- given term. An already existing mapping with the same variable will be --- thrown away. extendSubst :: Subst f -> VarIdx -> Term f -> Subst f extendSubst = addToFM --- Returns a substitution that contains all the mappings from the given list. --- For multiple mappings with the same variable, the last corresponding --- mapping of the given list is taken. listToSubst :: [(VarIdx, Term f)] -> Subst f listToSubst = listToFM substOrder --- Returns the term mapped to the given variable in a substitution or --- `Nothing` if no such mapping exists. lookupSubst :: Subst f -> VarIdx -> Maybe (Term f) lookupSubst = lookupFM --- Applies a substitution to the given term. applySubst :: Subst f -> Term f -> Term f applySubst sub t@(TermVar v) = fromMaybe t (lookupSubst sub v) applySubst sub (TermCons c ts) = TermCons c (map (applySubst sub) ts) --- Applies a substitution to both sides of the given term equation. applySubstEq :: Subst f -> TermEq f -> TermEq f applySubstEq sub = both (applySubst sub) --- Applies a substitution to every term equation in the given list. applySubstEqs :: Subst f -> TermEqs f -> TermEqs f applySubstEqs sub = map (applySubstEq sub) --- Returns a new substitution with only those mappings from the given --- substitution whose variable is in the given list of variables. restrictSubst :: Subst f -> [VarIdx] -> Subst f restrictSubst sub vs = listToSubst [(v, t) | v <- vs, (Just t) <- [lookupSubst sub v]] --- Composes the first substitution `phi` with the second substitution --- `sigma`. The resulting substitution `sub` fulfills the property --- `sub(t) = phi(sigma(t))` for a term `t`. Mappings in the first --- substitution shadow those in the second. composeSubst :: Subst f -> Subst f -> Subst f composeSubst phi sigma = plusFM phi (mapFM (\_ t -> applySubst phi t) sigma)curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Rewriting/Term.curry000066400000000000000000000167501305333611600252100ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for representation of first-order terms. --- --- This library is the basis of other libraries for the manipulation of --- first-order terms, e.g., unification of terms. Therefore, this library --- also defines other structures, like term equations. --- --- @author Jan-Hendrik Matthes --- @version August 2016 --- @category algorithm ------------------------------------------------------------------------------ module Rewriting.Term ( VarIdx, Term (..), TermEq, TermEqs , showVarIdx, showTerm, showTermEq, showTermEqs, tConst, tOp, tRoot, tCons , tConsAll, tVars, tVarsAll, isConsTerm, isVarTerm, isGround, isLinear , isNormal, maxVarInTerm, minVarInTerm, normalizeTerm, renameTermVars , mapTerm, eqConsPattern ) where import FiniteMap (listToFM, lookupFM) import List (nub, intercalate, maximum, minimum) import Maybe (fromMaybe) -- --------------------------------------------------------------------------- -- Representation of first-order terms and term equations -- --------------------------------------------------------------------------- --- A variable represented as an integer greater than or equal to zero. type VarIdx = Int --- Representation of a first-order term, parameterized over the kind of --- function symbols, e.g., strings. --- --- @cons TermVar v - The variable term with variable `v`. --- @cons TermCons c ts - The constructor term with constructor `c` and --- argument terms `ts`. data Term f = TermVar VarIdx | TermCons f [Term f] --- A term equation represented as a pair of terms and parameterized over the --- kind of function symbols, e.g., strings. type TermEq f = (Term f, Term f) --- Multiple term equations represented as a list of term equations and --- parameterized over the kind of function symbols, e.g., strings. type TermEqs f = [TermEq f] -- --------------------------------------------------------------------------- -- Pretty-printing of first-order terms and term equations -- --------------------------------------------------------------------------- --- Transforms a variable into a string representation. showVarIdx :: VarIdx -> String showVarIdx v | v >= 0 = if q == 0 then [c] else c:(show q) | otherwise = "" where (q, r) = divMod v 26 c = "abcdefghijklmnopqrstuvwxyz" !! r --- Transforms a term into a string representation. showTerm :: (f -> String) -> Term f -> String showTerm s = showTerm' False where showTerm' _ (TermVar v) = showVarIdx v showTerm' b (TermCons c ts) = case ts of [] -> s c [l, r] -> parensIf b ((showTerm' True l) ++ " " ++ (s c) ++ " " ++ (showTerm' True r)) _ -> (s c) ++ "(" ++ (intercalate "," (map (showTerm' False) ts)) ++ ")" --- Transforms a term equation into a string representation. showTermEq :: (f -> String) -> TermEq f -> String showTermEq s (l, r) = (showTerm s l) ++ " = " ++ (showTerm s r) --- Transforms a list of term equations into a string representation. showTermEqs :: (f -> String) -> TermEqs f -> String showTermEqs s = unlines . (map (showTermEq s)) -- --------------------------------------------------------------------------- -- Functions for first-order terms -- --------------------------------------------------------------------------- --- Returns a term with the given constructor and no argument terms. tConst :: f -> Term f tConst c = TermCons c [] --- Returns an infix operator term with the given constructor and the given --- left and right argument term. tOp :: Term f -> f -> Term f -> Term f tOp l c r = TermCons c [l, r] --- Returns the root symbol (variable or constructor) of a term. tRoot :: Term f -> Either VarIdx f tRoot (TermVar v) = Left v tRoot (TermCons c _) = Right c --- Returns a list without duplicates of all constructors in a term. tCons :: Term f -> [f] tCons = nub . tConsAll --- Returns a list of all constructors in a term. The resulting list may --- contain duplicates. tConsAll :: Term f -> [f] tConsAll (TermVar _) = [] tConsAll (TermCons c ts) = c:(concatMap tConsAll ts) --- Returns a list without duplicates of all variables in a term. tVars :: Term _ -> [VarIdx] tVars = nub . tVarsAll --- Returns a list of all variables in a term. The resulting list may contain --- duplicates. tVarsAll :: Term _ -> [VarIdx] tVarsAll (TermVar v) = [v] tVarsAll (TermCons _ ts) = concatMap tVarsAll ts --- Checks whether a term is a constructor term. isConsTerm :: Term _ -> Bool isConsTerm (TermVar _) = False isConsTerm (TermCons _ _) = True --- Checks whether a term is a variable term. isVarTerm :: Term _ -> Bool isVarTerm = not . isConsTerm --- Checks whether a term is a ground term (contains no variables). isGround :: Term _ -> Bool isGround = null . tVarsAll --- Checks whether a term is linear (contains no variable more than once). isLinear :: Term _ -> Bool isLinear = unique . tVarsAll --- Checks whether a term is normal (behind a variable is not a constructor). isNormal :: Term _ -> Bool isNormal (TermVar _) = True isNormal (TermCons _ []) = True isNormal (TermCons c (t:ts)) = case t of (TermVar _) -> all isVarTerm ts (TermCons _ _) -> (isNormal t) && (isNormal (TermCons c ts)) --- Returns the maximum variable in a term or `Nothing` if no variable exists. maxVarInTerm :: Term _ -> Maybe VarIdx maxVarInTerm t = case tVars t of [] -> Nothing vs@(_:_) -> Just (maximum vs) --- Returns the minimum variable in a term or `Nothing` if no variable exists. minVarInTerm :: Term _ -> Maybe VarIdx minVarInTerm t = case tVars t of [] -> Nothing vs@(_:_) -> Just (minimum vs) --- Normalizes a term by renaming all variables with an increasing order, --- starting from the minimum possible variable. normalizeTerm :: Term f -> Term f normalizeTerm t = normalize t where sub = listToFM (<) (zip (tVars t) (map TermVar [0..])) normalize t'@(TermVar v) = fromMaybe t' (lookupFM sub v) normalize (TermCons c ts) = TermCons c (map normalize ts) --- Renames the variables in a term by the given number. renameTermVars :: Int -> Term f -> Term f renameTermVars i (TermVar v) = TermVar (v + i) renameTermVars i (TermCons c ts) = TermCons c (map (renameTermVars i) ts) --- Transforms a term by applying a transformation on all constructors. mapTerm :: (a -> b) -> Term a -> Term b mapTerm _ (TermVar v) = TermVar v mapTerm f (TermCons c ts) = TermCons (f c) (map (mapTerm f) ts) --- Checks whether the constructor pattern of the first term is equal to the --- constructor pattern of the second term. Returns `True` if both terms have --- the same constructor and the same arity. eqConsPattern :: Term f -> Term f -> Bool eqConsPattern (TermVar _) _ = False eqConsPattern (TermCons _ _) (TermVar _) = False eqConsPattern (TermCons c1 ts1) (TermCons c2 ts2) = c1 == c2 && length ts1 == length ts2 -- --------------------------------------------------------------------------- -- Definition of helper functions -- --------------------------------------------------------------------------- --- Encloses a string in parenthesis if the given condition is true. parensIf :: Bool -> String -> String parensIf b s = if b then "(" ++ s ++ ")" else s --- Checks whether a list contains no element more than once. unique :: [_] -> Bool unique [] = True unique (x:xs) | notElem x xs = unique xs | otherwise = Falsecurry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Rewriting/Unification.curry000066400000000000000000000204671305333611600265510ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for representation of unification on first-order terms. --- --- This library implements a unification algorithm using reference tables. --- --- @author Michael Hanus, Jan-Hendrik Matthes, Jonas Oberschweiber, --- Bjoern Peemoeller --- @version August 2016 --- @category algorithm ------------------------------------------------------------------------------ module Rewriting.Unification ( UnificationError (..) , showUnificationError, unify, unifiable ) where import Either (isRight) import FiniteMap (FM, emptyFM, addToFM, lookupFM) import List (mapAccumL) import Rewriting.Substitution (Subst, emptySubst, extendSubst) import Rewriting.Term (VarIdx, Term (..), TermEq, TermEqs) import Rewriting.UnificationSpec (UnificationError (..), showUnificationError) -- --------------------------------------------------------------------------- -- Representation of internal data structures -- --------------------------------------------------------------------------- --- An `RTerm` is the unification algorithm's internal term representation. --- Its `RTermVar` and `RTermCons` constructors are similar to the `TermVar` --- and `TermCons` constructors of the original `Term` data type, but it has --- an additional `Ref` constructor. This `Ref` constructor is used to --- represent references into a reference table. data RTerm f = Ref VarIdx | RTermVar VarIdx | RTermCons f [RTerm f] --- A reference table used to store the values referenced by `Ref` terms --- represented as a finite map from variables to `RTerm`s and parameterized --- over the kind of function symbols, e.g., strings. type RefTable f = FM VarIdx (RTerm f) --- An `RTerm` equation represented as a pair of `RTerm`s and parameterized --- over the kind of function symbols, e.g., strings. type REq f = (RTerm f, RTerm f) --- Multiple `RTerm` equations represented as a list of `RTerm` equations and --- parameterized over the kind of function symbols, e.g., strings. type REqs f = [REq f] -- --------------------------------------------------------------------------- -- Definition of exported functions -- --------------------------------------------------------------------------- --- Unifies a list of term equations. Returns either a unification error or a --- substitution. unify :: TermEqs f -> Either (UnificationError f) (Subst f) unify eqs = let (rt, reqs) = termEqsToREqs eqs in either Left (\(rt', reqs') -> Right (eqsToSubst rt' reqs')) (unify' rt [] reqs) --- Checks whether a list of term equations can be unified. unifiable :: TermEqs _ -> Bool unifiable = isRight . unify -- --------------------------------------------------------------------------- -- Conversion to internal structure -- --------------------------------------------------------------------------- --- Converts a list of term equations into a list of `RTerm` equations and --- places references into a fresh reference table. termEqsToREqs :: TermEqs f -> (RefTable f, REqs f) termEqsToREqs = mapAccumL termEqToREq (emptyFM (<)) --- Converts a term equation into an `RTerm` equation. The given reference --- table is used to store references. termEqToREq :: RefTable f -> TermEq f -> (RefTable f, REq f) termEqToREq rt (l, r) = let (rt1, l') = termToRTerm rt l (rt2, r') = termToRTerm rt1 r in (rt2, (l', r')) --- Converts a term to an `RTerm`, placing all variable terms in the given --- reference table and replacing them by references inside the result --- `RTerm`. termToRTerm :: RefTable f -> Term f -> (RefTable f, RTerm f) termToRTerm rt (TermVar v) = (addToFM rt v (RTermVar v), Ref v) termToRTerm rt (TermCons c ts) = let (rt', ts') = mapAccumL termToRTerm rt ts in (rt', RTermCons c ts') -- --------------------------------------------------------------------------- -- Conversion from internal structure -- --------------------------------------------------------------------------- --- Converts a list of `RTerm` equations to a substitution by turning every --- equation of the form `(RTermVar v, t)` or `(t, RTermVar v)` into a mapping --- `(v, t)`. Equations that do not have a variable term on either side are --- ignored. Works on `RTerm`s, dereferences all `Ref`s. eqsToSubst :: RefTable f -> REqs f -> Subst f eqsToSubst _ [] = emptySubst eqsToSubst rt ((l, r):eqs) = case l of (Ref _) -> eqsToSubst rt ((deref rt l, r):eqs) (RTermVar v) -> extendSubst (eqsToSubst rt eqs) v (rTermToTerm rt r) (RTermCons _ _) -> case r of (Ref _) -> eqsToSubst rt ((l, deref rt r):eqs) (RTermVar v) -> extendSubst (eqsToSubst rt eqs) v (rTermToTerm rt l) _ -> eqsToSubst rt eqs --- Converts an `RTerm` to a term by dereferencing all references inside the --- `RTerm`. The given reference table is used for reference lookups. rTermToTerm :: RefTable f -> RTerm f -> Term f rTermToTerm rt t@(Ref _) = rTermToTerm rt (deref rt t) rTermToTerm _ (RTermVar v) = TermVar v rTermToTerm rt (RTermCons c ts) = TermCons c (map (rTermToTerm rt) ts) --- Dereferences an `RTerm` by following chained references. Simply returns --- the same value for `RTermVar` and `RTermCons`. The given reference table --- is used for reference lookups. deref :: RefTable f -> RTerm f -> RTerm f deref rt (Ref i) = case lookupFM rt i of Nothing -> error ("deref: " ++ (show i)) (Just t) -> case t of (Ref _) -> deref rt t (RTermVar _) -> t (RTermCons _ _) -> t deref _ t@(RTermVar _) = t deref _ t@(RTermCons _ _) = t -- --------------------------------------------------------------------------- -- Unification algorithm -- --------------------------------------------------------------------------- --- Internal unification function, the core of the algorithm. unify' :: RefTable f -> REqs f -> REqs f -> Either (UnificationError f) (RefTable f, REqs f) -- No equations left, we are done. unify' rt sub [] = Right (rt, sub) unify' rt sub (eq@(l, r):eqs) = case eq of -- Substitute the variable by the constructor term. (RTermVar v, RTermCons _ _) -> elim rt sub v r eqs (RTermCons _ _, RTermVar v) -> elim rt sub v l eqs -- If both variables are equal, simply remove the equation. -- Otherwise substitute the first variable by the second variable. (RTermVar v, RTermVar v') | v == v' -> unify' rt sub eqs | otherwise -> elim rt sub v r eqs -- If both constructors have the same name, equate their arguments. -- Otherwise fail with a clash. (RTermCons c1 ts1, RTermCons c2 ts2) | c1 == c2 -> unify' rt sub ((zip ts1 ts2) ++ eqs) | otherwise -> Left (Clash (rTermToTerm rt l) (rTermToTerm rt r)) -- If we encounter a Ref, simply dereference it and try again. _ -> unify' rt sub ((deref rt l, deref rt r):eqs) --- Substitutes a variable by a term inside a list of equations that have --- yet to be unified and the right-hand sides of all equations of the result --- list. Also adds a mapping from that variable to that term to the result --- list. elim :: RefTable f -> REqs f -> VarIdx -> RTerm f -> REqs f -> Either (UnificationError f) (RefTable f, REqs f) elim rt sub v t eqs | dependsOn rt (RTermVar v) t = Left (OccurCheck v (rTermToTerm rt t)) | otherwise = case t of (Ref _) -> error "elim" -- Make sure to place a Ref in the reference table and substitution, -- not the RTermVar itself. (RTermVar v') -> let rt' = addToFM rt v (Ref v') in unify' rt' ((RTermVar v, Ref v'):sub) eqs (RTermCons _ _) -> unify' (addToFM rt v t) ((RTermVar v, t):sub) eqs --- Checks whether the first term occurs as a subterm of the second term. dependsOn :: RefTable f -> RTerm f -> RTerm f -> Bool dependsOn rt l r = (l /= r) && (dependsOn' r) where dependsOn' :: RTerm f -> Bool dependsOn' x@(Ref _) = (deref rt x) == l dependsOn' t@(RTermVar _) = l == t dependsOn' (RTermCons _ ts) = or (map dependsOn' ts)curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Rewriting/UnificationSpec.curry000066400000000000000000000131011305333611600273470ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for specifying the unification on first-order terms. --- --- This library implements a general unification algorithm. Because the --- algorithm is easy to understand, but rather slow, it serves as a --- specification for more elaborate implementations. --- --- @author Michael Hanus, Jan-Hendrik Matthes, Jonas Oberschweiber, --- Bjoern Peemoeller --- @version August 2016 --- @category algorithm ------------------------------------------------------------------------------ module Rewriting.UnificationSpec ( UnificationError (..) , showUnificationError, unify, unifiable ) where import Either (isRight) import Function (both) import Rewriting.Substitution (Subst, emptySubst, extendSubst) import Rewriting.Term -- --------------------------------------------------------------------------- -- Representation of unification errors -- --------------------------------------------------------------------------- --- Representation of a unification error, parameterized over the kind of --- function symbols, e.g., strings. --- --- @cons Clash t1 t2 - The constructor term `t1` is supposed to be equal --- to the constructor term `t2` but has a different --- constructor. --- @cons OccurCheck v t - The variable `v` is supposed to be equal to the --- term `t` in which it occurs as a subterm. data UnificationError f = Clash (Term f) (Term f) | OccurCheck VarIdx (Term f) -- --------------------------------------------------------------------------- -- Pretty-printing of unification errors -- --------------------------------------------------------------------------- --- Transforms a unification error into a string representation. showUnificationError :: (f -> String) -> UnificationError f -> String showUnificationError s (Clash t1 t2) = "Clash: " ++ (showTerm s t1) ++ " is not equal to " ++ (showTerm s t2) ++ "." showUnificationError s (OccurCheck v t) = "OccurCheck: " ++ (showVarIdx v) ++ " occurs in " ++ (showTerm s t) ++ "." -- --------------------------------------------------------------------------- -- Functions for unification on first-order terms -- --------------------------------------------------------------------------- --- Unifies a list of term equations. Returns either a unification error or a --- substitution. unify :: TermEqs f -> Either (UnificationError f) (Subst f) unify = (either Left (Right . eqsToSubst)) . (unify' []) where eqsToSubst :: TermEqs f -> Subst f eqsToSubst [] = emptySubst eqsToSubst (eq@(l, r):eqs) = case l of (TermVar v) -> extendSubst (eqsToSubst eqs) v r (TermCons _ _) -> case r of (TermVar v) -> extendSubst (eqsToSubst eqs) v l (TermCons _ _) -> error ("eqsToSubst: " ++ (show eq)) --- Checks whether a list of term equations can be unified. unifiable :: TermEqs _ -> Bool unifiable = isRight . unify --- Unifies a list of term equations. The first argument specifies the current --- substitution represented by term equations. Returns either a unification --- error or a substitution represented by term equations. unify' :: TermEqs f -> TermEqs f -> Either (UnificationError f) (TermEqs f) unify' sub [] = Right sub unify' sub ((TermVar v, r@(TermCons _ _)):eqs) = elim sub v r eqs unify' sub ((l@(TermCons _ _), TermVar v):eqs) = elim sub v l eqs unify' sub ((TermVar v, r@(TermVar v')):eqs) | v == v' = unify' sub eqs | otherwise = elim sub v r eqs unify' sub ((l@(TermCons c1 ts1), r@(TermCons c2 ts2)):eqs) | c1 == c2 = unify' sub ((zip ts1 ts2) ++ eqs) | otherwise = Left (Clash l r) --- Substitutes a variable by a term inside a substitution and a list of term --- equations that have yet to be unified. Also adds a mapping from that --- variable to that term to the substitution. elim :: TermEqs f -> VarIdx -> Term f -> TermEqs f -> Either (UnificationError f) (TermEqs f) elim sub v t eqs | dependsOn (TermVar v) t = Left (OccurCheck v t) | otherwise = unify' sub' (substitute v t eqs) where sub' = (TermVar v, t):(map (\(l, r) -> (l, termSubstitute v t r)) sub) --- Substitutes a variable by a term inside another term. termSubstitute :: VarIdx -> Term f -> Term f -> Term f termSubstitute v t x@(TermVar v') | v == v' = t | otherwise = x termSubstitute v t (TermCons c ts) = TermCons c (termsSubstitute v t ts) --- Substitutes a variable by a term inside a list of terms. termsSubstitute :: VarIdx -> Term f -> [Term f] -> [Term f] termsSubstitute v t = map (termSubstitute v t) --- Substitutes a variable by a term inside a list of term equations. substitute :: VarIdx -> Term f -> TermEqs f -> TermEqs f substitute v t = map (substituteSingle v t) --- Substitutes a variable by a term inside a term equation. substituteSingle :: VarIdx -> Term f -> TermEq f -> TermEq f substituteSingle v t = both (termSubstitute v t) --- Checks whether the first term occurs as a subterm of the second term. dependsOn :: Term f -> Term f -> Bool dependsOn l r = and [not (l == r), dependsOn' l r] where dependsOn' :: Term f -> Term f -> Bool dependsOn' t v@(TermVar _) = t == v dependsOn' t (TermCons _ ts) = any id (map (dependsOn' t) ts)curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/SCC.curry000066400000000000000000000057321305333611600227350ustar00rootroot00000000000000--- ---------------------------------------------------------------------------- --- Computing strongly connected components --- --- Copyright (c) 2000 - 2003, Wolfgang Lux --- See LICENSE for the full license. --- --- The function `scc` computes the strongly connected components of a list --- of entities in two steps. First, the list is topologically sorted --- "downwards" using the *defines* relation. --- Then the resulting list is sorted "upwards" using the *uses* relation --- and partitioned into the connected components. Both relations --- are computed within this module using the bound and free names of each --- declaration. --- --- In order to avoid useless recomputations, the code in the module first --- decorates the declarations with their bound and free names and a --- unique number. The latter is only used to provide a trivial ordering --- so that the declarations can be used as set elements. --- --- @author Wolfgang Lux --- @category algorithm --- ---------------------------------------------------------------------------- module SCC (scc) where import SetRBT (emptySetRBT, elemRBT, insertRBT) data Node a b = Node Int [b] [b] a cmpNode :: Node a b -> Node a b -> Bool cmpNode n1 n2 = key n1 < key n2 key :: Node a b -> Int key (Node k _ _ _) = k bvs :: Node a b -> [b] bvs (Node _ bs _ _) = bs fvs :: Node a b -> [b] fvs (Node _ _ fs _) = fs node :: Node a b -> a node (Node _ _ _ n) = n --- Computes the strongly connected components of a list --- of entities. To be flexible, we distinguish the nodes and --- the entities defined in this node. --- --- @param defines - maps each node to the entities defined in this node --- @param uses - maps each node to the entities used in this node --- @param nodes - the list of nodes which should be sorted into --- strongly connected components --- @return the strongly connected components of the list of nodes scc :: (a -> [b]) -- ^ entities defined by node -> (a -> [b]) -- ^ entities used by node -> [a] -- ^ list of nodes -> [[a]] -- ^ strongly connected components scc bvs' fvs' = map (map node) . tsort' . tsort . zipWith wrap [0 ..] where wrap i n = Node i (bvs' n) (fvs' n) n tsort :: [Node a b] -> [Node a b] tsort xs = snd (dfs xs (emptySetRBT cmpNode) []) where dfs [] marks stack = (marks, stack) dfs (x : xs') marks stack | x `elemRBT` marks = dfs xs' marks stack | otherwise = dfs xs' marks' (x : stack') where (marks', stack') = dfs (defs x) (x `insertRBT` marks) stack defs x1 = filter (any (`elem` fvs x1) . bvs) xs tsort' :: [Node a b] -> [[Node a b]] tsort' xs = snd (dfs xs (emptySetRBT cmpNode) []) where dfs [] marks stack = (marks, stack) dfs (x : xs') marks stack | x `elemRBT` marks = dfs xs' marks stack | otherwise = dfs xs' marks' ((x : concat stack') : stack) where (marks', stack') = dfs (uses x) (x `insertRBT` marks) [] uses x1 = filter (any (`elem` bvs x1) . fvs) xs curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/SearchTree.curry000066400000000000000000000301401305333611600243410ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library defines a representation of a search space as --- a tree and various search strategies on this tree. --- This module implements **strong encapsulation** as discussed in --- [the JFLP'04 paper](http://www.informatik.uni-kiel.de/~mh/papers/JFLP04_findall.html). --- --- @author Michael Hanus, Bjoern Peemoeller, Fabian Reck --- @version February 2016 --- @category algorithm ------------------------------------------------------------------------------ module SearchTree ( SearchTree (..), someSearchTree, getSearchTree , isDefined, showSearchTree, searchTreeSize, limitSearchTree , Strategy , dfsStrategy, bfsStrategy, idsStrategy, idsStrategyWith, diagStrategy , allValuesWith , allValuesDFS, allValuesBFS, allValuesIDS, allValuesIDSwith, allValuesDiag , ValueSequence, vsToList , getAllValuesWith, printAllValuesWith, printValuesWith , someValue, someValueWith ) where import IO (hFlush,stdout) import List (diagonal) import ValueSequence --- A search tree is a value, a failure, or a choice between two search trees. data SearchTree a = Value a | Fail Int | Or (SearchTree a) (SearchTree a) --- A search strategy maps a search tree into some sequence of values. --- Using the abtract type of sequence of values (rather than list of values) --- enables the use of search strategies for encapsulated search --- with search trees (strong encapsulation) as well as --- with set functions (weak encapsulation). type Strategy a = SearchTree a -> ValueSequence a --- Returns the search tree for some expression. getSearchTree :: a -> IO (SearchTree a) getSearchTree x = return (someSearchTree x) --- Internal operation to return the search tree for some expression. --- Note that this operation is not purely declarative since --- the ordering in the resulting search tree depends on the --- ordering of the program rules. someSearchTree :: a -> SearchTree a someSearchTree external --- Returns True iff the argument is defined, i.e., has a value. isDefined :: a -> Bool isDefined x = hasValue (someSearchTree x) where hasValue y = case y of Value _ -> True Fail _ -> False Or t1 t2 -> hasValue t1 || hasValue t2 --- Shows the search tree as an intended line structure showSearchTree :: SearchTree _ -> String showSearchTree st = showsST [] st "" where -- `showsST ctxt `, where `ctxt` is a stack of boolean flags -- indicating whether we show the last alternative of the respective -- level to enable drawing aesthetical corners showsST ctxt (Value a) = indent ctxt . shows a . nl showsST ctxt (Fail _) = indent ctxt . showChar '!' . nl showsST ctxt (Or t1 t2) = indent ctxt . showChar '?' . nl . showsST (False : ctxt) t1 . showsST (True : ctxt) t2 indent [] = id indent (i:is) = showString (concatMap showIndent $ reverse is) . showChar (if i then llc else lmc) . showString (hbar : " ") where showIndent isLast = (if isLast then ' ' else vbar) : " " vbar = '\x2502' -- vertical bar hbar = '\x2500' -- horizontal bar llc = '\x2514' -- left lower corner lmc = '\x251c' -- left middle corner nl = showChar '\n' shows x = showString (show x) showChar c = (c:) showString s = (s++) -- showSearchTree st = showST 0 st "" -- where -- showST _ (Value a) = showString "Value: " . shows a . nl -- showST _ Fail = showString "Fail" . nl -- showST i (Or t1 t2) = showString "Or " -- . showST i' t1 . tab i' . showST i' t2 -- where i' = i + 1 -- tab j = showString $ replicate (3 * j) ' ' --- Returns the size (number of Value/Fail/Or nodes) of the search tree. searchTreeSize :: SearchTree _ -> (Int, Int, Int) searchTreeSize (Value _) = (1, 0, 0) searchTreeSize (Fail _) = (0, 1, 0) searchTreeSize (Or t1 t2) = let (v1, f1, o1) = searchTreeSize t1 (v2, f2, o2) = searchTreeSize t2 in (v1 + v2, f1 + f2, o1 + o2 + 1) --- Limit the depth of a search tree. Branches which a depth larger --- than the first argument are replace by `Fail (-1)`. limitSearchTree :: Int -> SearchTree a -> SearchTree a limitSearchTree _ v@(Value _) = v limitSearchTree _ f@(Fail _) = f limitSearchTree n (Or t1 t2) = if n<0 then Fail (-1) else Or (limitSearchTree (n-1) t1) (limitSearchTree (n-1) t2) ------------------------------------------------------------------------------ -- Definition of various search strategies: ------------------------------------------------------------------------------ --- Depth-first search strategy. dfsStrategy :: Strategy a dfsStrategy (Fail d) = failVS d dfsStrategy (Value x) = addVS x emptyVS dfsStrategy (Or x y) = dfsStrategy x |++| dfsStrategy y ------------------------------------------------------------------------------ --- Breadth-first search strategy. bfsStrategy :: Strategy a bfsStrategy t = allBFS [t] allBFS :: [SearchTree a] -> ValueSequence a allBFS [] = emptyVS allBFS (t:ts) = values (t:ts) |++| allBFS (children (t:ts)) children :: [SearchTree a] -> [SearchTree a] children [] = [] children (Fail _ : ts) = children ts children (Value _ : ts) = children ts children (Or x y : ts) = x:y:children ts -- Transforms a list of search trees into a value sequence where -- choices are ignored. values :: [SearchTree a] -> ValueSequence a values [] = emptyVS values (Fail d : ts) = failVS d |++| values ts values (Value x : ts) = addVS x (values ts) values (Or _ _ : ts) = values ts ------------------------------------------------------------------------------ --- Iterative-deepening search strategy. idsStrategy :: Strategy a idsStrategy t = idsStrategyWith defIDSDepth defIDSInc t --- The default initial search depth for IDS defIDSDepth :: Int defIDSDepth = 100 --- The default increasing function for IDS defIDSInc :: Int -> Int defIDSInc = (2*) --- Parameterized iterative-deepening search strategy. --- The first argument is the initial depth bound and --- the second argument is a function to increase the depth in each --- iteration. idsStrategyWith :: Int -> (Int -> Int) -> Strategy a idsStrategyWith initdepth incrdepth st = iterIDS initdepth (collectInBounds 0 initdepth st) where iterIDS _ Nil = emptyVS iterIDS n (Cons x xs) = addVS x (iterIDS n xs) iterIDS n (FCons fd xs) = failVS fd |++| iterIDS n xs iterIDS n Abort = let newdepth = incrdepth n in iterIDS newdepth (collectInBounds n newdepth st) -- Collect solutions within some level bounds in a tree. collectInBounds :: Int -> Int -> SearchTree a -> AbortList a collectInBounds oldbound newbound st = collectLevel newbound st where collectLevel d (Fail fd) = if d 0 then concA (collectLevel (d-1) x) (collectLevel (d-1) y) else Abort -- List containing "aborts" are used to implement the iterative -- depeening strategy: data AbortList a = Nil | Cons a (AbortList a) | FCons Int (AbortList a) | Abort -- Concatenation on abort lists where aborts are moved to the right. concA :: AbortList a -> AbortList a -> AbortList a concA Abort Abort = Abort concA Abort Nil = Abort concA Abort (Cons x xs) = Cons x (concA Abort xs) concA Abort (FCons d xs) = FCons d (concA Abort xs) concA Nil ys = ys concA (Cons x xs) ys = Cons x (concA xs ys) concA (FCons d xs) ys = FCons d (concA xs ys) ------------------------------------------------------------------------------ -- Diagonalization search according to -- J. Christiansen, S Fischer: EasyCheck - Test Data for Free (FLOPS 2008) --- Diagonalization search strategy. diagStrategy :: Strategy a diagStrategy st = values (diagonal (levels [st])) -- Enumerate all nodes of a forest of search trees in a level manner. levels :: [SearchTree a] -> [[SearchTree a]] levels st | null st = [] | otherwise = st : levels [ u | Or x y <- st, u <- [x,y] ] ------------------------------------------------------------------------------ -- Operations to map search trees into list of values. ------------------------------------------------------------------------------ --- Return all values in a search tree via some given search strategy. allValuesWith :: Strategy a -> SearchTree a -> [a] allValuesWith strategy searchtree = vsToList (strategy searchtree) --- Return all values in a search tree via depth-first search. allValuesDFS :: SearchTree a -> [a] allValuesDFS = allValuesWith dfsStrategy --- Return all values in a search tree via breadth-first search. allValuesBFS :: SearchTree a -> [a] allValuesBFS = allValuesWith bfsStrategy --- Return all values in a search tree via iterative-deepening search. allValuesIDS :: SearchTree a -> [a] allValuesIDS = allValuesIDSwith defIDSDepth defIDSInc --- Return all values in a search tree via iterative-deepening search. --- The first argument is the initial depth bound and --- the second argument is a function to increase the depth in each --- iteration. allValuesIDSwith :: Int -> (Int -> Int) -> SearchTree a -> [a] allValuesIDSwith initdepth incrdepth = allValuesWith (idsStrategyWith initdepth incrdepth) --- Return all values in a search tree via diagonalization search strategy. allValuesDiag :: SearchTree a -> [a] allValuesDiag = allValuesWith diagStrategy --- Gets all values of an expression w.r.t. a search strategy. --- A search strategy is an operation to traverse a search tree --- and collect all values, e.g., 'dfsStrategy' or 'bfsStrategy'. --- Conceptually, all values are computed on a copy of the expression, --- i.e., the evaluation of the expression does not share any results. getAllValuesWith :: Strategy a -> a -> IO [a] getAllValuesWith strategy exp = do t <- getSearchTree exp return (vsToList (strategy t)) --- Prints all values of an expression w.r.t. a search strategy. --- A search strategy is an operation to traverse a search tree --- and collect all values, e.g., 'dfsStrategy' or 'bfsStrategy'. --- Conceptually, all printed values are computed on a copy of the expression, --- i.e., the evaluation of the expression does not share any results. printAllValuesWith :: Strategy a -> a -> IO () printAllValuesWith strategy exp = getAllValuesWith strategy exp >>= mapIO_ print --- Prints the values of an expression w.r.t. a search strategy --- on demand by the user. Thus, the user must type before --- another value is computed and printed. --- A search strategy is an operation to traverse a search tree --- and collect all values, e.g., 'dfsStrategy' or 'bfsStrategy'. --- Conceptually, all printed values are computed on a copy of the expression, --- i.e., the evaluation of the expression does not share any results. printValuesWith :: Strategy a -> a -> IO () printValuesWith strategy exp = getAllValuesWith strategy exp >>= printValues where printValues [] = done printValues (x:xs) = do putStr (show x) hFlush stdout _ <- getLine printValues xs ------------------------------------------------------------------------------ --- Returns some value for an expression. --- --- Note that this operation is not purely declarative since --- the computed value depends on the ordering of the program rules. --- Thus, this operation should be used only if the expression --- has a single value. It fails if the expression has no value. someValue :: a -> a someValue = someValueWith bfsStrategy --- Returns some value for an expression w.r.t. a search strategy. --- A search strategy is an operation to traverse a search tree --- and collect all values, e.g., 'dfsStrategy' or 'bfsStrategy'. --- --- Note that this operation is not purely declarative since --- the computed value depends on the ordering of the program rules. --- Thus, this operation should be used only if the expression --- has a single value. It fails if the expression has no value. someValueWith :: Strategy a -> a -> a someValueWith strategy x = head (vsToList (strategy (someSearchTree x))) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/SearchTree.curry.pakcs000066400000000000000000000306601305333611600254500ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library defines a representation of a search space as --- a tree and various search strategies on this tree. --- This module implements **strong encapsulation** as discussed in --- [the JFLP'04 paper](http://www.informatik.uni-kiel.de/~mh/papers/JFLP04_findall.html). --- --- @author Michael Hanus, Bjoern Peemoeller, Fabian Reck --- @version February 2016 --- @category algorithm ------------------------------------------------------------------------------ module SearchTree ( SearchTree (..), someSearchTree, getSearchTree , isDefined, showSearchTree, searchTreeSize, limitSearchTree , Strategy , dfsStrategy, bfsStrategy, idsStrategy, idsStrategyWith, diagStrategy , allValuesWith , allValuesDFS, allValuesBFS, allValuesIDS, allValuesIDSwith, allValuesDiag , ValueSequence, vsToList , getAllValuesWith, printAllValuesWith, printValuesWith , someValue, someValueWith ) where import Findall (allValues) import IO (hFlush,stdout) import List (diagonal) import ValueSequence --- A search tree is a value, a failure, or a choice between two search trees. data SearchTree a = Value a | Fail Int | Or (SearchTree a) (SearchTree a) --- A search strategy maps a search tree into some sequence of values. --- Using the abtract type of sequence of values (rather than list of values) --- enables the use of search strategies for encapsulated search --- with search trees (strong encapsulation) as well as --- with set functions (weak encapsulation). type Strategy a = SearchTree a -> ValueSequence a --- Returns the search tree for some expression. getSearchTree :: a -> IO (SearchTree a) getSearchTree x = return (someSearchTree x) --- Internal operation to return the search tree for some expression. --- Note that this operation is not purely declarative since --- the ordering in the resulting search tree depends on the --- ordering of the program rules. --- --- Note that in PAKCS the search tree is just a degenerated tree --- representing all values of the argument expression --- and it is computed at once (i.e., not lazily!). someSearchTree :: a -> SearchTree a someSearchTree = list2st . allValues where list2st [] = Fail 0 list2st [x] = Value x list2st (x:y:ys) = Or (Value x) (list2st (y:ys)) --- Returns True iff the argument is defined, i.e., has a value. isDefined :: a -> Bool isDefined x = hasValue (someSearchTree x) where hasValue y = case y of Value _ -> True Fail _ -> False Or t1 t2 -> hasValue t1 || hasValue t2 --- Shows the search tree as an intended line structure showSearchTree :: SearchTree _ -> String showSearchTree st = showsST [] st "" where -- `showsST ctxt `, where `ctxt` is a stack of boolean flags -- indicating whether we show the last alternative of the respective -- level to enable drawing aesthetical corners showsST ctxt (Value a) = indent ctxt . shows a . nl showsST ctxt (Fail _) = indent ctxt . showChar '!' . nl showsST ctxt (Or t1 t2) = indent ctxt . showChar '?' . nl . showsST (False : ctxt) t1 . showsST (True : ctxt) t2 indent [] = id indent (i:is) = showString (concatMap showIndent $ reverse is) . showChar (if i then llc else lmc) . showString (hbar : " ") where showIndent isLast = (if isLast then ' ' else vbar) : " " vbar = '\x2502' -- vertical bar hbar = '\x2500' -- horizontal bar llc = '\x2514' -- left lower corner lmc = '\x251c' -- left middle corner nl = showChar '\n' shows x = showString (show x) showChar c = (c:) showString s = (s++) -- showSearchTree st = showST 0 st "" -- where -- showST _ (Value a) = showString "Value: " . shows a . nl -- showST _ Fail = showString "Fail" . nl -- showST i (Or t1 t2) = showString "Or " -- . showST i' t1 . tab i' . showST i' t2 -- where i' = i + 1 -- tab j = showString $ replicate (3 * j) ' ' --- Returns the size (number of Value/Fail/Or nodes) of the search tree. searchTreeSize :: SearchTree _ -> (Int, Int, Int) searchTreeSize (Value _) = (1, 0, 0) searchTreeSize (Fail _) = (0, 1, 0) searchTreeSize (Or t1 t2) = let (v1, f1, o1) = searchTreeSize t1 (v2, f2, o2) = searchTreeSize t2 in (v1 + v2, f1 + f2, o1 + o2 + 1) --- Limit the depth of a search tree. Branches which a depth larger --- than the first argument are replace by `Fail (-1)`. limitSearchTree :: Int -> SearchTree a -> SearchTree a limitSearchTree _ v@(Value _) = v limitSearchTree _ f@(Fail _) = f limitSearchTree n (Or t1 t2) = if n<0 then Fail (-1) else Or (limitSearchTree (n-1) t1) (limitSearchTree (n-1) t2) ------------------------------------------------------------------------------ -- Definition of various search strategies: ------------------------------------------------------------------------------ --- Depth-first search strategy. dfsStrategy :: Strategy a dfsStrategy (Fail d) = failVS d dfsStrategy (Value x) = addVS x emptyVS dfsStrategy (Or x y) = dfsStrategy x |++| dfsStrategy y ------------------------------------------------------------------------------ --- Breadth-first search strategy. bfsStrategy :: Strategy a bfsStrategy t = allBFS [t] allBFS :: [SearchTree a] -> ValueSequence a allBFS [] = emptyVS allBFS (t:ts) = values (t:ts) |++| allBFS (children (t:ts)) children :: [SearchTree a] -> [SearchTree a] children [] = [] children (Fail _ : ts) = children ts children (Value _ : ts) = children ts children (Or x y : ts) = x:y:children ts -- Transforms a list of search trees into a value sequence where -- choices are ignored. values :: [SearchTree a] -> ValueSequence a values [] = emptyVS values (Fail d : ts) = failVS d |++| values ts values (Value x : ts) = addVS x (values ts) values (Or _ _ : ts) = values ts ------------------------------------------------------------------------------ --- Iterative-deepening search strategy. idsStrategy :: Strategy a idsStrategy t = idsStrategyWith defIDSDepth defIDSInc t --- The default initial search depth for IDS defIDSDepth :: Int defIDSDepth = 100 --- The default increasing function for IDS defIDSInc :: Int -> Int defIDSInc = (2*) --- Parameterized iterative-deepening search strategy. --- The first argument is the initial depth bound and --- the second argument is a function to increase the depth in each --- iteration. idsStrategyWith :: Int -> (Int -> Int) -> Strategy a idsStrategyWith initdepth incrdepth st = iterIDS initdepth (collectInBounds 0 initdepth st) where iterIDS _ Nil = emptyVS iterIDS n (Cons x xs) = addVS x (iterIDS n xs) iterIDS n (FCons fd xs) = failVS fd |++| iterIDS n xs iterIDS n Abort = let newdepth = incrdepth n in iterIDS newdepth (collectInBounds n newdepth st) -- Collect solutions within some level bounds in a tree. collectInBounds :: Int -> Int -> SearchTree a -> AbortList a collectInBounds oldbound newbound st = collectLevel newbound st where collectLevel d (Fail fd) = if d 0 then concA (collectLevel (d-1) x) (collectLevel (d-1) y) else Abort -- List containing "aborts" are used to implement the iterative -- depeening strategy: data AbortList a = Nil | Cons a (AbortList a) | FCons Int (AbortList a) | Abort -- Concatenation on abort lists where aborts are moved to the right. concA :: AbortList a -> AbortList a -> AbortList a concA Abort Abort = Abort concA Abort Nil = Abort concA Abort (Cons x xs) = Cons x (concA Abort xs) concA Abort (FCons d xs) = FCons d (concA Abort xs) concA Nil ys = ys concA (Cons x xs) ys = Cons x (concA xs ys) concA (FCons d xs) ys = FCons d (concA xs ys) ------------------------------------------------------------------------------ -- Diagonalization search according to -- J. Christiansen, S Fischer: EasyCheck - Test Data for Free (FLOPS 2008) --- Diagonalization search strategy. diagStrategy :: Strategy a diagStrategy st = values (diagonal (levels [st])) -- Enumerate all nodes of a forest of search trees in a level manner. levels :: [SearchTree a] -> [[SearchTree a]] levels st | null st = [] | otherwise = st : levels [ u | Or x y <- st, u <- [x,y] ] ------------------------------------------------------------------------------ -- Operations to map search trees into list of values. ------------------------------------------------------------------------------ --- Return all values in a search tree via some given search strategy. allValuesWith :: Strategy a -> SearchTree a -> [a] allValuesWith strategy searchtree = vsToList (strategy searchtree) --- Return all values in a search tree via depth-first search. allValuesDFS :: SearchTree a -> [a] allValuesDFS = allValuesWith dfsStrategy --- Return all values in a search tree via breadth-first search. allValuesBFS :: SearchTree a -> [a] allValuesBFS = allValuesWith bfsStrategy --- Return all values in a search tree via iterative-deepening search. allValuesIDS :: SearchTree a -> [a] allValuesIDS = allValuesIDSwith defIDSDepth defIDSInc --- Return all values in a search tree via iterative-deepening search. --- The first argument is the initial depth bound and --- the second argument is a function to increase the depth in each --- iteration. allValuesIDSwith :: Int -> (Int -> Int) -> SearchTree a -> [a] allValuesIDSwith initdepth incrdepth = allValuesWith (idsStrategyWith initdepth incrdepth) --- Return all values in a search tree via diagonalization search strategy. allValuesDiag :: SearchTree a -> [a] allValuesDiag = allValuesWith diagStrategy --- Gets all values of an expression w.r.t. a search strategy. --- A search strategy is an operation to traverse a search tree --- and collect all values, e.g., 'dfsStrategy' or 'bfsStrategy'. --- Conceptually, all values are computed on a copy of the expression, --- i.e., the evaluation of the expression does not share any results. getAllValuesWith :: Strategy a -> a -> IO [a] getAllValuesWith strategy exp = do t <- getSearchTree exp return (vsToList (strategy t)) --- Prints all values of an expression w.r.t. a search strategy. --- A search strategy is an operation to traverse a search tree --- and collect all values, e.g., 'dfsStrategy' or 'bfsStrategy'. --- Conceptually, all printed values are computed on a copy of the expression, --- i.e., the evaluation of the expression does not share any results. printAllValuesWith :: Strategy a -> a -> IO () printAllValuesWith strategy exp = getAllValuesWith strategy exp >>= mapIO_ print --- Prints the values of an expression w.r.t. a search strategy --- on demand by the user. Thus, the user must type before --- another value is computed and printed. --- A search strategy is an operation to traverse a search tree --- and collect all values, e.g., 'dfsStrategy' or 'bfsStrategy'. --- Conceptually, all printed values are computed on a copy of the expression, --- i.e., the evaluation of the expression does not share any results. printValuesWith :: Strategy a -> a -> IO () printValuesWith strategy exp = getAllValuesWith strategy exp >>= printValues where printValues [] = done printValues (x:xs) = do putStr (show x) hFlush stdout _ <- getLine printValues xs ------------------------------------------------------------------------------ --- Returns some value for an expression. --- --- Note that this operation is not purely declarative since --- the computed value depends on the ordering of the program rules. --- Thus, this operation should be used only if the expression --- has a single value. It fails if the expression has no value. someValue :: a -> a someValue = someValueWith bfsStrategy --- Returns some value for an expression w.r.t. a search strategy. --- A search strategy is an operation to traverse a search tree --- and collect all values, e.g., 'dfsStrategy' or 'bfsStrategy'. --- --- Note that this operation is not purely declarative since --- the computed value depends on the ordering of the program rules. --- Thus, this operation should be used only if the expression --- has a single value. It fails if the expression has no value. someValueWith :: Strategy a -> a -> a someValueWith strategy x = head (vsToList (strategy (someSearchTree x))) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/SearchTreeGenerators.curry000066400000000000000000000161561305333611600264060ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library implements some operations to generate search trees --- for various data types. --- --- The library also provides combinators to support the easy definition --- of search tree generators for user-defined data types. --- If a data type is defined by --- --- data T a1 ... an = ... | C t1 ... tn | .... --- --- then one can define a search tree generator for this type by --- --- genT gena1 ... genan = --- ... ||| genCons C gen_t1 ... gen_t1 ||| ... --- --- where `gen_ti` denotes the search tree generator for type `ti`. --- For instance, a search tree generator for the type --- --- data Tree a = Leaf a --- | Node [Tree a] --- --- can be defined by --- --- genTree gena = genCons1 Leaf gena --- ||| genCons1 Node (genList (genTree gena)) --- --- @author Michael Hanus --- @version February 2017 --- @category algorithm ------------------------------------------------------------------------------ module SearchTreeGenerators ( genBool, genNat, genInt, genFloat, genChar, genList , genMaybe, genEither, genUnit, genPair, genTriple, genTuple4, genTuple5 , genOrdering , genCons0, genCons1, genCons2, genCons3, genCons4, genCons5 , (|||) ) where import Float import SearchTree import SearchTreeTraversal infixr 1 ||| --- Replace in a given search tree each value node by a new search tree --- according to the function provided as the second argument. valsTo :: SearchTree a -> (a -> SearchTree b) -> SearchTree b valsTo (Value a) f = f a valsTo (Fail i) _ = Fail i valsTo (Or t1 t2) f = Or (valsTo t1 f) (valsTo t2 f) --- Constructs an alternative of two search trees. (|||) :: SearchTree a -> SearchTree a -> SearchTree a x ||| y = Or x y --- Constructs a generator for a nullary constructor. genCons0 :: a -> SearchTree a genCons0 = Value --- Constructs a generator for a unary constructor where the generator --- for the argument type is provided. genCons1 :: (a -> b) -> SearchTree a -> SearchTree b genCons1 c gena = valsTo gena (Value . c) --- Constructs a generator for a binary constructor where the generators --- for the argument types are provided. genCons2 :: (a1 -> a2 -> b) -> SearchTree a1 -> SearchTree a2 -> SearchTree b genCons2 c gena1 gena2 = valsTo gena1 (\a1 -> valsTo gena2 (\a2 -> Value (c a1 a2))) --- Constructs a generator for a ternary constructor where the generators --- for the argument types are provided. genCons3 :: (a1 -> a2 -> a3 -> b) -> SearchTree a1 -> SearchTree a2 -> SearchTree a3 -> SearchTree b genCons3 c gena1 gena2 gena3 = valsTo gena1 (\a1 -> valsTo gena2 (\a2 -> valsTo gena3 (\a3 -> Value (c a1 a2 a3)))) --- Constructs a generator for a constructor of arity 4 where the generators --- for the argument types are provided. genCons4 :: (a1 -> a2 -> a3 -> a4 -> b) -> SearchTree a1 -> SearchTree a2 -> SearchTree a3 -> SearchTree a4 -> SearchTree b genCons4 c gena1 gena2 gena3 gena4 = valsTo gena1 (\a1 -> valsTo gena2 (\a2 -> valsTo gena3 (\a3 -> valsTo gena4 (\a4 -> Value (c a1 a2 a3 a4))))) --- Constructs a generator for a constructor of arity 5 where the generators --- for the argument types are provided. genCons5 :: (a1 -> a2 -> a3 -> a4 -> a5 -> b) -> SearchTree a1 -> SearchTree a2 -> SearchTree a3 -> SearchTree a4 -> SearchTree a5 -> SearchTree b genCons5 c gena1 gena2 gena3 gena4 gena5 = valsTo gena1 (\a1 -> valsTo gena2 (\a2 -> valsTo gena3 (\a3 -> valsTo gena4 (\a4 -> valsTo gena5 (\a5 -> Value (c a1 a2 a3 a4 a5)))))) ------------------------------------------------------------------------------ -- Generators for specific types: --- Generates a search tree for positive natural numbers: genNat :: SearchTree Int genNat = Or (Value 1) (Or (valsTo genNat (\n -> Value (2*n))) (valsTo genNat (\n -> Value (2*n+1)))) --- Generates a search tree for integer values. genInt :: SearchTree Int genInt = Or genNat (Or (Value 0) (valsTo genNat (Value . (0 -)))) --- Generates a search tree for Float values. genFloat :: SearchTree Float genFloat = Or genPosFloat (Or (Value 0.0) (valsTo genPosFloat (Value . (0.0 -.)))) --- Generates a search tree for positive Float values. genPosFloat :: SearchTree Float genPosFloat = valsTo (genPair genNat genNat) ii2f where -- Combine two naturals to a float value: ii2f (x,y) = Value (i2f x +. nat2float 0.1 y) -- Transform an natural to float<1, e.g., nat2float 0.1 135 = 0.531 nat2float m i = if i == 0 then 0.0 else nat2float (m/.10) (i `div` 10) +. m *. i2f (i `mod` 10) --- Generates a search tree for Boolean values. genBool :: SearchTree Bool genBool = Or (Value False) (Value True) --- Generates a search tree for character values. --- In order to obtain readable values, we only generate letters and digits. genChar :: SearchTree Char genChar = foldr1 Or (map Value chars) where chars = map chr ([65..90] ++ [97..122] ++ [48..57]) -- or use this for generating all characters: -- genChar = valsTo genNat (Value . chr . (+1)) --- Generates a search tree for list values where the search tree for --- the elements is given as a parameter. genList :: SearchTree a -> SearchTree [a] genList genx = Or (Value []) (genCons2 (:) genx (genList genx)) --- Generates a search tree for `Maybe` values where the search tree for --- the possible element is given as a parameter. genMaybe :: SearchTree a -> SearchTree (Maybe a) genMaybe genx = Value Nothing ||| genCons1 Just genx --- Generates a search tree for `Either` values where the search tree for --- the possible elements is given as a parameter. genEither :: SearchTree a -> SearchTree b -> SearchTree (Either a b) genEither genx geny = genCons1 Left genx ||| genCons1 Right geny --- Generates a search tree for the unit values. genUnit :: SearchTree () genUnit = Value () --- Generates a search tree for pair of values where the search tree generators --- for the components types are given as parameters. genPair :: SearchTree a -> SearchTree b -> SearchTree (a,b) genPair = genCons2 (\x y -> (x,y)) --- Generates a search tree for triple of values where the search tree --- generators for the components types are given as parameters. genTriple :: SearchTree a -> SearchTree b -> SearchTree c -> SearchTree (a,b,c) genTriple = genCons3 (\x y z -> (x,y,z)) --- Generates a search tree for quadruple of values where the search tree --- generators for the components types are given as parameters. genTuple4 :: SearchTree a -> SearchTree b -> SearchTree c -> SearchTree d -> SearchTree (a,b,c,d) genTuple4 = genCons4 (\x y z1 z2 -> (x,y,z1,z2)) --- Generates a search tree for 5-tuple of values where the search tree --- generators for the components types are given as parameters. genTuple5 :: SearchTree a -> SearchTree b -> SearchTree c -> SearchTree d -> SearchTree e -> SearchTree (a,b,c,d,e) genTuple5 = genCons5 (\x y z1 z2 z3 -> (x,y,z1,z2,z3)) --- Generates a search tree for the `Ordering` values. genOrdering :: SearchTree Ordering genOrdering = Or (Value LT) (Or (Value EQ) (Value GT)) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/SearchTreeTraversal.curry000066400000000000000000000060631305333611600262340ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Implements additional traversals on search trees. --- --- @author Sebastian Fischer --- @version February 2016 --- @category algorithm ------------------------------------------------------------------------------ module SearchTreeTraversal ( depthDiag, rndDepthDiag, levelDiag, rndLevelDiag, rndLevelDiagFlat ) where import List ( diagonal ) import Random ( nextInt, nextIntRange, shuffle ) import SearchTree --- Splits a random seeds into new seeds. --- The range avoids large negative seeds (which cause problems with PAKCS). split :: Int -> [Int] split n = nextIntRange n 2147483648 --- diagonalized depth first search. --- --- @param t search tree --- @return enumeration of values in given search tree --- depthDiag :: SearchTree a -> [a] depthDiag t = [ x | Value x <- dfsDiag t ] dfsDiag :: SearchTree a -> [SearchTree a] -- dfsDiag Suspend = [] dfsDiag (Fail _) = [] dfsDiag t@(Value _) = [t] dfsDiag (Or t1 t2) = diagonal (map dfsDiag [t1,t2]) --- randomized variant of diagonalized depth first search. --- --- @param t search tree --- @return enumeration of values in given search tree --- rndDepthDiag :: Int -> SearchTree a -> [a] rndDepthDiag rnd t = [ x | Value x <- rndDfsDiag rnd t ] rndDfsDiag :: Int -> SearchTree a -> [SearchTree a] -- rndDfsDiag _ Suspend = [] rndDfsDiag _ (Fail _) = [] rndDfsDiag _ t@(Value _) = [t] rndDfsDiag rnd (Or t1 t2) = diagonal (zipWith rndDfsDiag rs (shuffle r [t1,t2])) where r:rs = split rnd --- diagonalization of devels. --- --- @param t search tree --- @return enumeration of values in given search tree --- levelDiag :: SearchTree a -> [a] levelDiag t = [ x | Value x <- diagonal (levels [t]) ] levels :: [SearchTree a] -> [[SearchTree a]] levels ts | null ts = [] | otherwise = ts : levels [ u | Or u1 u2 <- ts, u <- [u1,u2] ] --- randomized diagonalization of levels. --- --- @param t search tree --- @return enumeration of values in given search tree --- rndLevelDiag :: Int -> SearchTree a -> [a] rndLevelDiag rnd t = [ x | Value x <- diagonal (rndLevels rnd [t]) ] rndLevels :: Int -> [SearchTree a] -> [[SearchTree a]] rndLevels rnd ts | null ts = [] | otherwise = ts : rndLevels r (concat (zipWith shuffle rs [ [u1,u2] | Or u1 u2 <- ts ])) where r:rs = split rnd --- randomized diagonalization of levels with flattening. rndLevelDiagFlat :: Int -> Int -> SearchTree a -> [a] rndLevelDiagFlat d rnd t = concat $ transpose (zipWith rndLevelDiag rs (flatRep d [t])) where rs = split rnd flat :: SearchTree a -> [SearchTree a] flat t@(Value _) = [t] flat (Fail _) = [] -- pretend Fail ~ Or [] flat (Or t1 t2) = [t1,t2] flatRep :: Int -> [SearchTree a] -> [SearchTree a] flatRep n ts | n==0 = ts | otherwise = flatRep (n-1) (concatMap flat ts) -- auxiliary functions transpose :: [[a]] -> [[a]] transpose [] = [] transpose ([] : xss) = transpose xss transpose ((x:xs) : xss) = (x : [h | (h:_) <- xss]) : transpose (xs : [t | (_:t) <- xss]) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/SetFunctions.curry000066400000000000000000000263441305333611600247530ustar00rootroot00000000000000------------------------------------------------------------------------ --- This module contains an implementation of set functions. --- The general idea of set functions is described in: --- --- > S. Antoy, M. Hanus: Set Functions for Functional Logic Programming --- > Proc. 11th International Conference on Principles and Practice --- > of Declarative Programming (PPDP'09), pp. 73-82, ACM Press, 2009 --- --- Intuition: If `f` is an n-ary function, then `(setn f)` is a set-valued --- function that collects all non-determinism caused by f (but not --- the non-determinism caused by evaluating arguments!) in a set. --- Thus, `(setn f a1 ... an)` returns the set of all --- values of `(f b1 ... bn)` where `b1`,...,`bn` are values --- of the arguments `a1`,...,`an` (i.e., the arguments are --- evaluated "outside" this capsule so that the non-determinism --- caused by evaluating these arguments is not captured in this capsule --- but yields several results for `(setn...)`. --- Similarly, logical variables occuring in `a1`,...,`an` are not bound --- inside this capsule. --- --- The set of values returned by a set function is represented --- by an abstract type 'Values' on which several operations are --- defined in this module. Actually, it is a multiset of values, --- i.e., duplicates are not removed. --- --- The handling of failures and nested occurrences of set functions --- is not specified in the previous paper. Thus, a detailed description --- of the semantics of set functions as implemented in this library --- can be found in the paper --- --- > J. Christiansen, M. Hanus, F. Reck, D. Seidel: --- > A Semantics for Weakly Encapsulated Search in Functional Logic Programs --- > Proc. 15th International Conference on Principles and Practice --- > of Declarative Programming (PPDP'13), pp. 49-60, ACM Press, 2013 --- --- @author Michael Hanus, Fabian Reck --- @version June 2014 --- @category general ------------------------------------------------------------------------ module SetFunctions (set0,set1,set2,set3,set4,set5,set6,set7 ,set0With,set1With,set2With,set3With,set4With,set5With,set6With,set7With ,Values,isEmpty,notEmpty,valueOf ,choose,chooseValue,select,selectValue ,mapValues,foldValues,minValue,maxValue ,values2list,printValues,sortValues,sortValuesBy ) where import Sort(mergeSortBy) import SearchTree import List(delete) --- Combinator to transform a 0-ary function into a corresponding set function. set0 :: b -> Values b set0 f = set0With dfsStrategy f --- Combinator to transform a 0-ary function into a corresponding set function --- that uses a given strategy to compute its values. set0With :: Strategy b -> b -> Values b set0With s f = Values (vsToList (s (someSearchTree f))) --- Combinator to transform a unary function into a corresponding set function. set1 :: (a1 -> b) -> a1 -> Values b set1 f x = set1With dfsStrategy f x --- Combinator to transform a unary function into a corresponding set function --- that uses a given strategy to compute its values. set1With :: Strategy b -> (a1 -> b) -> a1 -> Values b set1With s f x = allVs s (\_ -> f x) --- Combinator to transform a binary function into a corresponding set function. set2 :: (a1 -> a2 -> b) -> a1 -> a2 -> Values b set2 f x1 x2 = set2With dfsStrategy f x1 x2 --- Combinator to transform a binary function into a corresponding set function --- that uses a given strategy to compute its values. set2With :: Strategy b -> (a1 -> a2 -> b) -> a1 -> a2 -> Values b set2With s f x1 x2 = allVs s (\_ -> f x1 x2) --- Combinator to transform a function of arity 3 --- into a corresponding set function. set3 :: (a1 -> a2 -> a3 -> b) -> a1 -> a2 -> a3 -> Values b set3 f x1 x2 x3 = set3With dfsStrategy f x1 x2 x3 --- Combinator to transform a function of arity 3 --- into a corresponding set function --- that uses a given strategy to compute its values. set3With :: Strategy b -> (a1 -> a2 -> a3 -> b) -> a1 -> a2 -> a3 -> Values b set3With s f x1 x2 x3 = allVs s (\_ -> f x1 x2 x3) --- Combinator to transform a function of arity 4 --- into a corresponding set function. set4 :: (a1 -> a2 -> a3 -> a4 -> b) -> a1 -> a2 -> a3 -> a4 -> Values b set4 f x1 x2 x3 x4 = set4With dfsStrategy f x1 x2 x3 x4 --- Combinator to transform a function of arity 4 --- into a corresponding set function --- that uses a given strategy to compute its values. set4With :: Strategy b -> (a1 -> a2 -> a3 -> a4 -> b) -> a1 -> a2 -> a3 -> a4 -> Values b set4With s f x1 x2 x3 x4 = allVs s (\_ -> f x1 x2 x3 x4) --- Combinator to transform a function of arity 5 --- into a corresponding set function. set5 :: (a1 -> a2 -> a3 -> a4 -> a5 -> b) -> a1 -> a2 -> a3 -> a4 -> a5 -> Values b set5 f x1 x2 x3 x4 x5 = set5With dfsStrategy f x1 x2 x3 x4 x5 --- Combinator to transform a function of arity 5 --- into a corresponding set function --- that uses a given strategy to compute its values. set5With :: Strategy b -> (a1 -> a2 -> a3 -> a4 -> a5 -> b) -> a1 -> a2 -> a3 -> a4 -> a5 -> Values b set5With s f x1 x2 x3 x4 x5 = allVs s (\_ -> f x1 x2 x3 x4 x5) --- Combinator to transform a function of arity 6 --- into a corresponding set function. set6 :: (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> b) -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> Values b set6 f x1 x2 x3 x4 x5 x6 = set6With dfsStrategy f x1 x2 x3 x4 x5 x6 --- Combinator to transform a function of arity 6 --- into a corresponding set function --- that uses a given strategy to compute its values. set6With :: Strategy b -> (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> b) -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> Values b set6With s f x1 x2 x3 x4 x5 x6 = allVs s (\_ -> f x1 x2 x3 x4 x5 x6) --- Combinator to transform a function of arity 7 --- into a corresponding set function. set7 :: (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> b) -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> Values b set7 f x1 x2 x3 x4 x5 x6 x7 = set7With dfsStrategy f x1 x2 x3 x4 x5 x6 x7 --- Combinator to transform a function of arity 7 --- into a corresponding set function --- that uses a given strategy to compute its values. set7With :: Strategy b -> (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> b) -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> Values b set7With s f x1 x2 x3 x4 x5 x6 x7 = allVs s (\_ -> f x1 x2 x3 x4 x5 x6 x7) ------------------------------------------------------------------------ -- Axuiliaries: -- Collect all values of an expression (represented as a constant function) -- in a list: allVs :: Strategy a -> (() -> a) -> Values a allVs s f = Values (vsToList ((incDepth $!! s) ((incDepth $!! someSearchTree) ((incDepth $!! f) ())))) -- Apply a function to an argument where the encapsulation level of the -- argument is incremented. incDepth :: (a -> b) -> a -> b incDepth external ---------------------------------------------------------------------- --- Abstract type representing multisets of values. data Values a = Values [a] --- Is a multiset of values empty? isEmpty :: Values _ -> Bool isEmpty (Values vs) = null vs --- Is a multiset of values not empty? notEmpty :: Values _ -> Bool notEmpty vs = not (isEmpty vs) --- Is some value an element of a multiset of values? valueOf :: a -> Values a -> Bool valueOf e (Values s) = e `elem` s --- Chooses (non-deterministically) some value in a multiset of values --- and returns the chosen value and the remaining multiset of values. --- Thus, if we consider the operation `chooseValue` by --- --- chooseValue x = fst (choose x) --- --- then `(set1 chooseValue)` is the identity on value sets, i.e., --- `(set1 chooseValue s)` contains the same elements as the --- value set `s`. choose :: Values a -> (a,Values a) choose (Values vs) = (x, Values xs) where x = foldr1 (?) vs xs = delete x vs --- Chooses (non-deterministically) some value in a multiset of values --- and returns the chosen value. --- Thus, `(set1 chooseValue)` is the identity on value sets, i.e., --- `(set1 chooseValue s)` contains the same elements as the --- value set `s`. chooseValue :: Values a -> a chooseValue s = fst (choose s) --- Selects (indeterministically) some value in a multiset of values --- and returns the selected value and the remaining multiset of values. --- Thus, `select` has always at most one value. --- It fails if the value set is empty. --- --- **NOTE:** --- The usage of this operation is only safe (i.e., does not destroy --- completeness) if all values in the argument set are identical. select :: Values a -> (a,Values a) select (Values (x:xs)) = (x, Values xs) --- Selects (indeterministically) some value in a multiset of values --- and returns the selected value. --- Thus, `selectValue` has always at most one value. --- It fails if the value set is empty. --- --- **NOTE:** --- The usage of this operation is only safe (i.e., does not destroy --- completeness) if all values in the argument set are identical. selectValue :: Values a -> a selectValue s = fst (select s) --- Accumulates all elements of a multiset of values by applying a binary --- operation. This is similarly to fold on lists, but the binary operation --- must be commutative so that the result is independent of the order --- of applying this operation to all elements in the multiset. mapValues :: (a -> b) -> Values a -> Values b mapValues f (Values s) = Values (map f s) --- Accumulates all elements of a multiset of values by applying a binary --- operation. This is similarly to fold on lists, but the binary operation --- must be commutative so that the result is independent of the order --- of applying this operation to all elements in the multiset. foldValues :: (a -> a -> a) -> a -> Values a -> a foldValues f z (Values s) = foldr f z s --- Returns the minimal element of a non-empty multiset of values --- with respect to a given total ordering on the elements. minValue :: (a -> a -> Bool) -> Values a -> a minValue leq (Values s) = minOf s where minOf [x] = x minOf (x:y:ys) = let m1 = minOf (y:ys) in if leq x m1 then x else m1 --- Returns the maximal element of a non-empty multiset of value --- with respect to a given total ordering on the elements. maxValue :: (a -> a -> Bool) -> Values a -> a maxValue leq (Values s) = maxOf s where maxOf [x] = x maxOf (x:y:ys) = let m1 = maxOf (y:ys) in if leq x m1 then m1 else x --- Puts all elements of a multiset of values in a list. --- Since the order of the elements in the list might depend on --- the time of the computation, this operation is an I/O action. values2list :: Values a -> IO [a] values2list (Values s) = return s --- Prints all elements of a multiset of values. printValues :: Values _ -> IO () printValues s = values2list s >>= mapIO_ print --- Transforms a multiset of values into a list sorted by --- the standard term ordering. As a consequence, the multiset of values --- is completely evaluated. sortValues :: Values a -> [a] sortValues = sortValuesBy (<=) --- Transforms a multiset of values into a list sorted by a given ordering --- on the values. As a consequence, the multiset of values --- is completely evaluated. --- In order to ensure that the result of this operation is independent of the --- evaluation order, the given ordering must be a total order. sortValuesBy :: (a -> a -> Bool) -> Values a -> [a] sortValuesBy leq (Values s) = mergeSortBy leq s ------------------------------------------------------------------------ curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/SetFunctions.curry.pakcs000066400000000000000000000240571305333611600260520ustar00rootroot00000000000000------------------------------------------------------------------------ --- This module contains an implementation of set functions. --- The general idea of set functions --- is described in: --- --- > S. Antoy, M. Hanus: Set Functions for Functional Logic Programming --- > Proc. 11th International Conference on Principles and Practice --- > of Declarative Programming (PPDP'09), pp. 73-82, ACM Press, 2009 --- --- Intuition: If `f` is an n-ary function, then `(setn f)` is a set-valued --- function that collects all non-determinism caused by f (but not --- the non-determinism caused by evaluating arguments!) in a set. --- Thus, `(setn f a1 ... an)` returns the set of all --- values of `(f b1 ... bn)` where `b1`,...,`bn` are values --- of the arguments `a1`,...,`an` (i.e., the arguments are --- evaluated "outside" this capsule so that the non-determinism --- caused by evaluating these arguments is not captured in this capsule --- but yields several results for `(setn...)`. --- Similarly, logical variables occuring in `a1`,...,`an` are not bound --- inside this capsule (but causes a suspension until they are bound). --- The set of values returned by a set function is represented --- by an abstract type 'Values' on which several operations are --- defined in this module. Actually, it is a multiset of values, --- i.e., duplicates are not removed. --- --- Restrictions: --- 1. The set is a multiset, i.e., it might contain multiple values. --- 2. The multiset of values is completely evaluated when demanded. --- Thus, if it is infinite, its evaluation will not terminate --- even if only some elements (e.g., for a containment test) --- are demanded. However, for the emptiness test, at most one --- value will be computed --- 3. The arguments of a set function are strictly evaluated before --- the set functions itself will be evaluated. --- --- Since this implementation is restricted and prototypical, --- the interface is not stable and might change. --- --- @author Michael Hanus --- @version July 2014 --- @category general ------------------------------------------------------------------------ module SetFunctions (set0,set1,set2,set3,set4,set5,set6,set7 ,Values,isEmpty,notEmpty,valueOf ,choose,chooseValue,select,selectValue ,mapValues,foldValues,minValue,maxValue ,values2list,printValues,sortValues,sortValuesBy ) where import Findall import Sort(mergeSortBy) import List(delete) --- Combinator to transform a 0-ary function into a corresponding set function. set0 :: b -> Values b set0 f = Values (someValue f) (findall (=:=f)) --- Combinator to transform a unary function into a corresponding set function. set1 :: (a1 -> b) -> a1 -> Values b set1 f x | x=:=x = Values (someValue (f x)) (findall (=:=(f x))) --- Combinator to transform a binary function into a corresponding set function. set2 :: (a1 -> a2 -> b) -> a1 -> a2 -> Values b set2 f x1 x2 | x1=:=x1 & x2=:=x2 = Values (someValue (f x1 x2)) (findall (=:=(f x1 x2))) --- Combinator to transform a function of arity 3 --- into a corresponding set function. set3 :: (a1 -> a2 -> a3 -> b) -> a1 -> a2 -> a3 -> Values b set3 f x1 x2 x3 | x1=:=x1 & x2=:=x2 & x3=:=x3 = Values (someValue (f x1 x2 x3)) (findall (=:=(f x1 x2 x3))) --- Combinator to transform a function of arity 4 --- into a corresponding set function. set4 :: (a1 -> a2 -> a3 -> a4 -> b) -> a1 -> a2 -> a3 -> a4 -> Values b set4 f x1 x2 x3 x4 | x1=:=x1 & x2=:=x2 & x3=:=x3 & x4=:=x4 = Values (someValue (f x1 x2 x3 x4)) (findall (=:=(f x1 x2 x3 x4))) --- Combinator to transform a function of arity 5 --- into a corresponding set function. set5 :: (a1 -> a2 -> a3 -> a4 -> a5 -> b) -> a1 -> a2 -> a3 -> a4 -> a5 -> Values b set5 f x1 x2 x3 x4 x5 | x1=:=x1 & x2=:=x2 & x3=:=x3 & x4=:=x4 & x5=:=x5 = Values (someValue (f x1 x2 x3 x4 x5)) (findall (=:=(f x1 x2 x3 x4 x5))) --- Combinator to transform a function of arity 6 --- into a corresponding set function. set6 :: (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> b) -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> Values b set6 f x1 x2 x3 x4 x5 x6 | x1=:=x1 & x2=:=x2 & x3=:=x3 & x4=:=x4 & x5=:=x5 & x6=:=x6 = Values (someValue (f x1 x2 x3 x4 x5 x6)) (findall (=:=(f x1 x2 x3 x4 x5 x6))) --- Combinator to transform a function of arity 7 --- into a corresponding set function. set7 :: (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> b) -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> Values b set7 f x1 x2 x3 x4 x5 x6 x7 | x1=:=x1 & x2=:=x2 & x3=:=x3 & x4=:=x4 & x5=:=x5 & x6=:=x6 & x7=:=x7 = Values (someValue (f x1 x2 x3 x4 x5 x6 x7)) (findall (=:=(f x1 x2 x3 x4 x5 x6 x7))) ------------------------------------------------------------------------ --- Abstract type representing multisets of values. data Values a = Values (Maybe a) [a] -- The first component is `Nothing` iff the multiset is empty, -- otherwise it is the first value (this enables -- also an emptiness check or selection of a single value -- even for infinite sets of values). -- The second component contains the set of all values (it will be -- completely evaluated if its value is demanded). --- Computes some value of a given expression. --- This implementation is specific to PAKCS in order to --- to implement `notEmpty` and `selectValue` efficiently and --- also for possibly infinite result sets. someValue :: a -> Maybe a someValue e = let xs = findall (=:= (findfirst (=:=e))) in if null xs then Nothing else Just (head xs) --- Is a multiset of values empty? isEmpty :: Values _ -> Bool isEmpty (Values firstval _) = firstval == Nothing --- Is a multiset of values not empty? notEmpty :: Values _ -> Bool notEmpty vs = not (isEmpty vs) --- Is some value an element of a multiset of values? valueOf :: a -> Values a -> Bool valueOf e (Values _ s) = e `elem` s --- Chooses (non-deterministically) some value in a multiset of values --- and returns the chosen value and the remaining multiset of values. --- Thus, if we consider the operation `chooseValue` by --- --- chooseValue x = fst (choose x) --- --- then `(set1 chooseValue)` is the identity on value sets, i.e., --- `(set1 chooseValue s)` contains the same elements as the --- value set `s`. choose :: Values a -> (a,Values a) choose (Values _ vs) = (x, Values (if null xs then Nothing else Just (head xs)) xs) where x = foldr1 (?) vs xs = delete x vs --- Chooses (non-deterministically) some value in a multiset of values --- and returns the chosen value. --- Thus, `(set1 chooseValue)` is the identity on value sets, i.e., --- `(set1 chooseValue s)` contains the same elements as the --- value set `s`. chooseValue :: Values a -> a chooseValue s = fst (choose s) --- Selects (indeterministically) some value in a multiset of values --- and returns the selected value and the remaining multiset of values. --- Thus, `select` has always at most one value. --- It fails if the value set is empty. --- --- **NOTE:** --- The usage of this operation is only safe (i.e., does not destroy --- completeness) if all values in the argument set are identical. select :: Values a -> (a,Values a) select (Values _ (x:xs)) = (x, Values (if null xs then Nothing else Just (head xs)) xs) --- Selects (indeterministically) some value in a multiset of values --- and returns the selected value. --- Thus, `selectValue` has always at most one value. --- It fails if the value set is empty. --- --- **NOTE:** --- The usage of this operation is only safe (i.e., does not destroy --- completeness) if all values in the argument set are identical. --- It returns a single value even for infinite value sets --- (in contrast to `select` or `choose`). selectValue :: Values a -> a selectValue (Values (Just val) _) = val --- Accumulates all elements of a multiset of values by applying a binary --- operation. This is similarly to fold on lists, but the binary operation --- must be commutative so that the result is independent of the order --- of applying this operation to all elements in the multiset. mapValues :: (a -> b) -> Values a -> Values b mapValues f (Values mbval s) = Values (maybe Nothing (Just . f) mbval) (map f s) --- Accumulates all elements of a multiset of values by applying a binary --- operation. This is similarly to fold on lists, but the binary operation --- must be commutative so that the result is independent of the order --- of applying this operation to all elements in the multiset. foldValues :: (a -> a -> a) -> a -> Values a -> a foldValues f z (Values _ s) = foldr f z s --- Returns the minimal element of a non-empty multiset of values --- with respect to a given total ordering on the elements. minValue :: (a -> a -> Bool) -> Values a -> a minValue leq (Values _ s) = minOf s where minOf [x] = x minOf (x:y:ys) = let m1 = minOf (y:ys) in if leq x m1 then x else m1 --- Returns the maximal element of a non-empty multiset of value --- with respect to a given total ordering on the elements. maxValue :: (a -> a -> Bool) -> Values a -> a maxValue leq (Values _ s) = maxOf s where maxOf [x] = x maxOf (x:y:ys) = let m1 = maxOf (y:ys) in if leq x m1 then m1 else x --- Puts all elements of a multiset of values in a list. --- Since the order of the elements in the list might depend on --- the time of the computation, this operation is an I/O action. values2list :: Values a -> IO [a] values2list (Values _ s) = return s --- Prints all elements of a multiset of values. printValues :: Values _ -> IO () printValues s = values2list s >>= mapIO_ print --- Transforms a multiset of values into a list sorted by --- the standard term ordering. As a consequence, the multiset of values --- is completely evaluated. sortValues :: Values a -> [a] sortValues = sortValuesBy (<=) --- Transforms a multiset of values into a list sorted by a given ordering --- on the values. As a consequence, the multiset of values --- is completely evaluated. --- In order to ensure that the result of this operation is independent of the --- evaluation order, the given ordering must be a total order. sortValuesBy :: (a -> a -> Bool) -> Values a -> [a] sortValuesBy leq (Values _ s) = mergeSortBy leq s ------------------------------------------------------------------------ curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/SetRBT.curry000066400000000000000000000051471305333611600234300ustar00rootroot00000000000000---------------------------------------------------------------------------- --- Library with an implementation of sets as red-black trees. --- --- All the operations on sets are generic, i.e., one has to provide --- an explicit order predicate `(<)` (less-than) on elements. --- --- @author Johannes Koj, Michael Hanus, Bernd Brassel --- @version March 2013 --- @category algorithm ---------------------------------------------------------------------------- module SetRBT where import qualified RedBlackTree as RBT import Maybe (isJust) type SetRBT a = RBT.RedBlackTree a --- Returns an empty set, i.e., an empty red-black tree --- augmented with an order predicate. emptySetRBT :: (a -> a -> Bool) -> SetRBT a emptySetRBT = RBT.empty (==) (==) --- Test for an empty set. isEmptySetRBT :: SetRBT _ -> Bool isEmptySetRBT = RBT.isEmpty --- Returns true if an element is contained in a (red-black tree) set. --- @param e - an element to be checked for containment --- @param s - a set (represented as a red-black tree) --- @return True if e is contained in s elemRBT :: a -> SetRBT a -> Bool elemRBT e = isJust . (RBT.lookup e) --- Inserts an element into a set if it is not already there. insertRBT :: a -> SetRBT a -> SetRBT a insertRBT = RBT.update --- Inserts an element into a multiset. --- Thus, the same element can have several occurrences in the multiset. insertMultiRBT :: a -> SetRBT a -> SetRBT a insertMultiRBT e = RBT.setInsertEquivalence (==) . RBT.update e . RBT.setInsertEquivalence (\ _ _ -> False) --- delete an element from a set. --- Deletes only a single element from a multi set deleteRBT :: a -> SetRBT a -> SetRBT a deleteRBT = RBT.delete --- Transforms a (red-black tree) set into an ordered list of its elements. setRBT2list :: SetRBT a -> [a] setRBT2list = RBT.tree2list --- Computes the union of two (red-black tree) sets. --- This is done by inserting all elements of the first set into the --- second set. unionRBT :: SetRBT a -> SetRBT a -> SetRBT a unionRBT s1 s2 = foldr insertRBT s2 (setRBT2list s1) --- Computes the intersection of two (red-black tree) sets. --- This is done by inserting all elements of the first set --- contained in the second set into a new set, which order --- is taken from the first set. intersectRBT :: SetRBT a -> SetRBT a -> SetRBT a intersectRBT s1 s2 = foldr insertRBT (RBT.newTreeLike s1) (filter (`elemRBT` s2) (setRBT2list s1)) --- Generic sort based on insertion into red-black trees. --- The first argument is the order for the elements. sortRBT :: (a -> a -> Bool) -> [a] -> [a] sortRBT = RBT.sortBy curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Setup.hs000066400000000000000000000000551305333611600226640ustar00rootroot00000000000000import Distribution.Simple main = defaultMaincurry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/ShowS.curry000066400000000000000000000034541305333611600233670ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- This library provides a type and combinators for show functions using --- functional lists. --- --- @author Bjoern Peemoeller --- @version April 2016 --- @category general -------------------------------------------------------------------------------- module ShowS ( ShowS , showString, showChar, showParen, shows , space, nl, sep, replicateS, concatS ) where import Test.Prop type ShowS = String -> String --- Prepend a string showString :: String -> ShowS showString s = (s ++) showStringIsString s = showString s [] -=- s showStringConcat s1 s2 = (showString s1 . showString s2) [] -=- s1++s2 --- Prepend a single character showChar :: Char -> ShowS showChar c = (c:) --- Surround the inner show function with parentheses if the first argument --- evaluates to `True`. showParen :: Bool -> ShowS -> ShowS showParen True s = showChar '(' . s . showChar ')' showParen False s = s --- Convert a value to `ShowS` using the standard show function. shows :: a -> ShowS shows = showString . show --- Prepend a space space :: ShowS space = showChar ' ' --- Prepend a newline nl :: ShowS nl = showChar '\n' --- Separate a list of `ShowS` sep :: ShowS -> [ShowS] -> ShowS sep _ [] = id sep s xs@(_:_) = foldr1 (\ f g -> f . s . g) xs --- Replicate a `ShowS` a given number of times replicateS :: Int -> ShowS -> ShowS replicateS n funcS | n <= 0 = id | otherwise = funcS . replicateS (n - 1) funcS replicateSIsConRep n s = n>=0 ==> replicateS n (showString s) [] -=- concat (replicate n s) --- Concatenate a list of `ShowS` concatS :: [ShowS] -> ShowS concatS [] = id concatS xs@(_:_) = foldr1 (\ f g -> f . g) xs concatSIsConcat xs = concatS (map showString xs) [] -=- concat xs curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Socket.curry000066400000000000000000000061371305333611600235550ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library to support network programming with sockets. --- In standard applications, the server side uses the operations --- listenOn and socketAccept to provide some service --- on a socket, and the client side uses the operation --- connectToSocket to request a service. --- --- @author Michael Hanus --- @version February 2008 --- @category general ------------------------------------------------------------------------------ module Socket(Socket, listenOn, listenOnFresh, socketAccept, waitForSocketAccept, sClose, connectToSocket) where import System import IO(Handle) --- The abstract type of sockets. data Socket --------------------------------------------------------------------- -- Server side operations: --- Creates a server side socket bound to a given port number. listenOn :: Int -> IO Socket listenOn port = prim_listenOn $# port prim_listenOn :: Int -> IO Socket prim_listenOn external --- Creates a server side socket bound to a free port. --- The port number and the socket is returned. listenOnFresh :: IO (Int,Socket) listenOnFresh external --- Returns a connection of a client to a socket. --- The connection is returned as a pair consisting of a string identifying --- the client (the format of this string is implementation-dependent) --- and a handle to a stream communication with the client. --- The handle is both readable and writable. socketAccept :: Socket -> IO (String,Handle) socketAccept s = prim_socketAccept $## s prim_socketAccept :: Socket -> IO (String,Handle) prim_socketAccept external --- Waits until a connection of a client to a socket is available. --- If no connection is available within the time limit, it returns Nothing, --- otherwise the connection is returned as a pair consisting --- of a string identifying the client --- (the format of this string is implementation-dependent) --- and a handle to a stream communication with the client. --- @param socket - a socket --- @param timeout - milliseconds to wait for input (< 0 : no time out) waitForSocketAccept :: Socket -> Int -> IO (Maybe (String,Handle)) waitForSocketAccept s timeout = (prim_waitForSocketAccept $## s) $# timeout prim_waitForSocketAccept :: Socket -> Int -> IO (Maybe (String,Handle)) prim_waitForSocketAccept external --- Closes a server socket. sClose :: Socket -> IO () sClose s = prim_sClose $## s prim_sClose :: Socket -> IO () prim_sClose external --------------------------------------------------------------------- -- Client side operations: --- Creates a new connection to a Unix socket. --- @param host - the host name of the connection --- @param port - the port number of the connection --- @return the handle of the stream (connected to the port port@host) --- which is both readable and writable connectToSocket :: String -> Int -> IO Handle connectToSocket host port = (prim_connectToSocket $## host) $# port prim_connectToSocket :: String -> Int -> IO Handle prim_connectToSocket external --------------------------------------------------------------------- curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Socket.prim_c2p000066400000000000000000000016411305333611600241170ustar00rootroot00000000000000 prim_socket prim_listenOn prim_socket prim_listenOnFresh prim_socket prim_socketAccept prim_socket prim_waitForSocketAccept prim_socket prim_sClose prim_socket prim_connectToSocket curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Sort.curry000066400000000000000000000176651305333611600232640ustar00rootroot00000000000000------------------------------------------------------------------------------ --- A collection of useful functions for sorting and comparing --- characters, strings, and lists. --- --- @author Michael Hanus --- @version April 2016 --- @category algorithm ------------------------------------------------------------------------------ {-# OPTIONS_CYMAKE -Wno-overlapping #-} module Sort( sort, sortBy, sorted, sortedBy , permSort, permSortBy, insertionSort, insertionSortBy , quickSort, quickSortBy, mergeSort, mergeSortBy , cmpChar, cmpList, cmpString , leqChar, leqCharIgnoreCase, leqList , leqString, leqStringIgnoreCase, leqLexGerman ) where import Char import Test.Prop --- The default sorting operation, mergeSort, with standard ordering `<=`. sort :: [a] -> [a] sort = sortBy (<=) -- Postcondition: input and output lists have same length and output is sorted. sort'post :: [a] -> [a] -> Bool sort'post xs ys = length xs == length ys && sorted ys -- Specification via permutation sort: sort'spec :: [a] -> [a] sort'spec xs = permSort xs --- The default sorting operation: mergeSort sortBy :: (a -> a -> Bool) -> [a] -> [a] sortBy = mergeSortBy --- `sorted xs` is satisfied if the elements `xs` are in ascending order. sorted :: [a] -> Bool sorted = sortedBy (<=) --- `sortedBy leq xs` is satisfied if all adjacent elements of the list `xs` --- satisfy the ordering predicate `leq`. sortedBy :: (a -> a -> Bool) -> [a] -> Bool sortedBy _ [] = True sortedBy _ [_] = True sortedBy leq (x:y:ys) = leq x y && sortedBy leq (y:ys) ------------------------------------------------------------------------------ --- Permutation sort with standard ordering `<=`. --- Sorts a list by finding a sorted permutation --- of the input. This is not a usable way to sort a list but it can be used --- as a specification of other sorting algorithms. permSort :: [a] -> [a] permSort = permSortBy (<=) --- Permutation sort with ordering as first parameter. --- Sorts a list by finding a sorted permutation --- of the input. This is not a usable way to sort a list but it can be used --- as a specification of other sorting algorithms. permSortBy :: (a -> a -> Bool) -> [a] -> [a] permSortBy leq xs | ys == perm xs && sortedBy leq ys = ys where ys free --- Computes a permutation of a list. perm :: [a] -> [a] perm [] = [] perm (x:xs) = insert (perm xs) where insert ys = x : ys insert (y:ys) = y : insert ys ------------------------------------------------------------------------------ --- Insertion sort with standard ordering `<=`. --- The list is sorted by repeated sorted insertion of the elements --- into the already sorted part of the list. insertionSort :: [a] -> [a] insertionSort = insertionSortBy (<=) -- Postcondition: input and output lists have same length and output is sorted. insertionSort'post :: [a] -> [a] -> Bool insertionSort'post xs ys = length xs == length ys && sorted ys -- Specification via permutation sort: insertionSort'spec :: [a] -> [a] insertionSort'spec = permSort --- Insertion sort with ordering as first parameter. --- The list is sorted by repeated sorted insertion of the elements --- into the already sorted part of the list. insertionSortBy :: (a -> a -> Bool) -> [a] -> [a] insertionSortBy _ [] = [] insertionSortBy leq (x:xs) = insert (insertionSortBy leq xs) where insert [] = [x] insert zs@(y:ys) | leq x y = x : zs | otherwise = y : insert ys ------------------------------------------------------------------------------ --- Quicksort with standard ordering `<=`. --- The classical quicksort algorithm on lists. quickSort :: [a] -> [a] quickSort = quickSortBy (<=) -- Postcondition: input and output lists have same length and output is sorted. quickSort'post :: [a] -> [a] -> Bool quickSort'post xs ys = length xs == length ys && sorted ys -- Specification via permutation sort: quickSort'spec :: [a] -> [a] quickSort'spec = permSort --- Quicksort with ordering as first parameter. --- The classical quicksort algorithm on lists. quickSortBy :: (a -> a -> Bool) -> [a] -> [a] quickSortBy _ [] = [] quickSortBy leq (x:xs) = let (l,r) = split x xs in quickSortBy leq l ++ (x : quickSortBy leq r) where split _ [] = ([],[]) split e (y:ys) | leq y e = (y:l,r) | otherwise = (l,y:r) where (l,r) = split e ys ------------------------------------------------------------------------------ --- Bottom-up mergesort with standard ordering `<=`. mergeSort :: [a] -> [a] mergeSort = mergeSortBy (<=) -- Postcondition: input and output lists have same length and output is sorted. mergeSort'post :: [a] -> [a] -> Bool mergeSort'post xs ys = length xs == length ys && sorted ys -- Specification via permutation sort: mergeSort'spec :: [a] -> [a] mergeSort'spec = permSort --- Bottom-up mergesort with ordering as first parameter. mergeSortBy :: (a -> a -> Bool) -> [a] -> [a] mergeSortBy leq zs = mergeLists (genRuns zs) where -- generate runs of length 2: genRuns [] = [] genRuns [x] = [[x]] genRuns (x1:x2:xs) | leq x1 x2 = [x1,x2] : genRuns xs | otherwise = [x2,x1] : genRuns xs -- merge the runs: mergeLists [] = [] mergeLists [x] = x mergeLists (x1:x2:xs) = mergeLists (merge leq x1 x2 : mergePairs xs) mergePairs [] = [] mergePairs [x] = [x] mergePairs (x1:x2:xs) = merge leq x1 x2 : mergePairs xs --- Merges two lists with respect to an ordering predicate. merge :: (a -> a -> Bool) -> [a] -> [a] -> [a] merge _ [] ys = ys merge _ (x:xs) [] = x : xs merge leq (x:xs) (y:ys) | leq x y = x : merge leq xs (y:ys) | otherwise = y : merge leq (x:xs) ys ------------------------------------------------------------------------------ -- Comparing lists, characters and strings --- Less-or-equal on lists. leqList :: (a -> a -> Bool) -> [a] -> [a] -> Bool leqList _ [] _ = True leqList _ (_:_) [] = False leqList leq (x:xs) (y:ys) | x == y = leqList leq xs ys | otherwise = leq x y --- Comparison of lists. cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering cmpList _ [] [] = EQ cmpList _ [] (_:_) = LT cmpList _ (_:_) [] = GT cmpList cmp (x:xs) (y:ys) | cmp x y == EQ = cmpList cmp xs ys | otherwise = cmp x y --- Less-or-equal on characters (deprecated, use 'Prelude.<='). leqChar :: Char -> Char -> Bool leqChar = (<=) --- Comparison of characters (deprecated, use 'Prelude.compare'). cmpChar :: Char -> Char -> Ordering cmpChar = compare --- Less-or-equal on characters ignoring case considerations. leqCharIgnoreCase :: Char -> Char -> Bool leqCharIgnoreCase c1 c2 = (toUpper c1) <= (toUpper c2) --- Less-or-equal on strings (deprecated, use 'Prelude.<='). leqString :: String -> String -> Bool leqString = (<=) --- Comparison of strings (deprecated, use 'Prelude.compare'). cmpString :: String -> String -> Ordering cmpString = compare --- Less-or-equal on strings ignoring case considerations. leqStringIgnoreCase :: String -> String -> Bool leqStringIgnoreCase = leqList leqCharIgnoreCase --- Lexicographical ordering on German strings. --- Thus, upper/lowercase are not distinguished and Umlauts are sorted --- as vocals. leqLexGerman :: String -> String -> Bool leqLexGerman [] _ = True leqLexGerman (_:_) [] = False leqLexGerman (x:xs) (y:ys) | x' == y' = leqLexGerman xs ys | otherwise = x' < y' where x' = glex (ord x) y' = glex (ord y) -- map umlauts to vocals and make everything lowercase: glex o | o >= ord 'A' && o <= ord 'Z' = o + (ord 'a' - ord 'A') | o == 228 = ord 'a' | o == 246 = ord 'o' | o == 252 = ord 'u' | o == 196 = ord 'a' | o == 214 = ord 'o' | o == 220 = ord 'u' | o == 223 = ord 's' | otherwise = o -- end module Sort curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/State.curry000066400000000000000000000034431305333611600234020ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library provides an implementation of the state monad. --- --- @author Jan-Hendrik Matthes, Bjoern Peemoeller, Fabian Skrlac --- @version August 2016 --- @category general ------------------------------------------------------------------------------ module State ( State , bindS, bindS_, returnS, getS, putS, modifyS, sequenceS, sequenceS_, mapS , mapS_, runState, evalState, execState, liftS, liftS2 ) where infixl 1 `bindS`, `bindS_` type State s a = s -> (a, s) bindS :: State s a -> (a -> State s b) -> State s b bindS state f s = case state s of (x, newS) -> newS `seq` (f x newS) bindS_ :: State s a -> State s b -> State s b bindS_ a b = a `bindS` (\_ -> b) returnS :: a -> State s a returnS x s = (x, s) getS :: State s s getS s = (s, s) putS :: s -> State s () putS newS _ = ((), newS) modifyS :: (s -> s) -> State s () modifyS f s = ((), f s) sequenceS :: [State s a] -> State s [a] sequenceS = foldr (\s newS -> s `bindS` (\a -> newS `bindS` (\as -> returnS (a:as)))) (returnS []) sequenceS_ :: [State s a] -> State s () sequenceS_ = foldr bindS_ (returnS ()) mapS :: (a -> State s b) -> [a] -> State s [b] mapS f = sequenceS . (map f) mapS_ :: (a -> State s b) -> [a] -> State s () mapS_ f = sequenceS_ . (map f) runState :: State s a -> s -> (a, s) runState state s = state s evalState :: State s a -> s -> a evalState state s = fst (runState state s) execState :: State s a -> s -> s execState state s = snd (runState state s) liftS :: (a -> b) -> State s a -> State s b liftS f act = act `bindS` (returnS . f) liftS2 :: (a -> b -> c) -> State s a -> State s b -> State s c liftS2 f a b = a `bindS` (\x -> b `bindS` (\y -> returnS (f x y)))curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/System.curry000066400000000000000000000101271305333611600236030ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library to access parts of the system environment. --- --- @author Michael Hanus, Bernd Brassel, Bjoern Peemoeller --- @version July 2012 --- @category general ------------------------------------------------------------------------------ module System ( getCPUTime,getElapsedTime , getArgs, getEnviron, setEnviron, unsetEnviron, getProgName , getHostname, getPID, system, exitWith, sleep , isPosix, isWindows ) where import Global --- Returns the current cpu time of the process in milliseconds. getCPUTime :: IO Int getCPUTime external --- Returns the current elapsed time of the process in milliseconds. --- This operation is not supported in KiCS2 (there it always returns 0), --- but only included for compatibility reasons. getElapsedTime :: IO Int getElapsedTime external --- Returns the list of the program's command line arguments. --- The program name is not included. getArgs :: IO [String] getArgs external --- Returns the value of an environment variable. --- The empty string is returned for undefined environment variables. getEnviron :: String -> IO String getEnviron evar = do envs <- readGlobal environ maybe (prim_getEnviron $## evar) return (lookup evar envs) prim_getEnviron :: String -> IO String prim_getEnviron external --- internal state of environment variables set via setEnviron environ :: Global [(String,String)] environ = global [] Temporary --- Set an environment variable to a value. --- The new value will be passed to subsequent shell commands --- (see system) and visible to subsequent calls to --- getEnviron (but it is not visible in the environment --- of the process that started the program execution). setEnviron :: String -> String -> IO () setEnviron evar val = do envs <- readGlobal environ writeGlobal environ ((evar,val) : filter ((/=evar) . fst) envs) --- Removes an environment variable that has been set by --- setEnviron. unsetEnviron :: String -> IO () unsetEnviron evar = do envs <- readGlobal environ writeGlobal environ (filter ((/=evar) . fst) envs) --- Returns the hostname of the machine running this process. getHostname :: IO String getHostname external --- Returns the process identifier of the current Curry process. getPID :: IO Int getPID external --- Returns the name of the current program, i.e., the name of the --- main module currently executed. getProgName :: IO String getProgName external --- Executes a shell command and return with the exit code of the command. --- An exit status of zero means successful execution. system :: String -> IO Int system cmd = do envs <- readGlobal environ prim_system $## (concatMap envToExport envs ++ escapedCmd) where win = isWindows -- This is a work around for GHC ticket #5376 -- (http://hackage.haskell.org/trac/ghc/ticket/5376) escapedCmd = if win then '\"' : cmd ++ "\"" else cmd envToExport (var, val) = if win then "set " ++ var ++ "=" ++ concatMap escapeWinSpecials val ++ " && " else var ++ "='" ++ concatMap encodeShellSpecials val ++ "' ; export " ++ var ++ " ; " escapeWinSpecials c = if c `elem` "<>|&^" then ['^', c] else [c] encodeShellSpecials c = if c == '\'' then map chr [39,34,39,34,39] else [c] prim_system :: String -> IO Int prim_system external --- Terminates the execution of the current Curry program --- and returns the exit code given by the argument. --- An exit code of zero means successful execution. exitWith :: Int -> IO _ exitWith exitcode = prim_exitWith $# exitcode prim_exitWith :: Int -> IO _ prim_exitWith external --- The evaluation of the action (sleep n) puts the Curry process --- asleep for n seconds. sleep :: Int -> IO () sleep n = prim_sleep $# n prim_sleep :: Int -> IO () prim_sleep external --- Is the underlying operating system a POSIX system (unix, MacOS)? isPosix :: Bool isPosix = not isWindows --- Is the underlying operating system a Windows system? isWindows :: Bool isWindows external curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/System.prim_c2p000066400000000000000000000027001305333611600241500ustar00rootroot00000000000000 prim_system prim_getCPUTime prim_system prim_getElapsedTime prim_system prim_getArgs prim_system prim_getEnviron prim_system prim_getHostname prim_system prim_getPID prim_system prim_getProgName prim_system prim_system prim_system prim_exitWith prim_system prim_sleep prim_system isWindows curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/TableRBT.curry000066400000000000000000000037441305333611600237250ustar00rootroot00000000000000--------------------------------------------------------------------------- --- Library with an implementation of tables as red-black trees: ---

--- A table is a finite mapping from keys to values. --- All the operations on tables are generic, i.e., one has to provide --- an explicit order predicate ("cmp" below) on elements. --- Each inner node in the red-black tree contains a key-value association. --- --- @author Johannes Koj, Michael Hanus, Bernd Brassel --- @version March 2005 --- @category algorithm ---------------------------------------------------------------------------- module TableRBT where import qualified RedBlackTree as RBT --import RedBlackTree (RedBlackTree) -- uncomment for old (buggy) Java front end ---------------------------------------------------------------------------- -- the main interface: type TableRBT key a = RBT.RedBlackTree (key,a) --- Returns an empty table, i.e., an empty red-black tree. emptyTableRBT :: (a -> a -> Bool) -> TableRBT a _ emptyTableRBT lt = RBT.empty (\ x y -> fst x==fst y) (\ x y -> fst x==fst y) (\ x y -> lt (fst x) (fst y)) --- tests whether a given table is empty isEmptyTable :: TableRBT _ _ -> Bool isEmptyTable = RBT.isEmpty --- Looks up an entry in a table. --- @param k - a key under which a value is stored --- @param t - a table (represented as a red-black tree) --- @return (Just v) if v is the value stored with key k, --- otherwise Nothing is returned. lookupRBT :: key -> TableRBT key a -> Maybe a lookupRBT k = maybe Nothing (Just . snd) . RBT.lookup (k,failed) --- Inserts or updates an element in a table. updateRBT :: key -> a -> TableRBT key a -> TableRBT key a updateRBT k e = RBT.update (k,e) --- Transforms the nodes of red-black tree into a list. tableRBT2list :: TableRBT key a -> [(key,a)] tableRBT2list = RBT.tree2list deleteRBT :: key -> TableRBT key a -> TableRBT key a deleteRBT key = RBT.delete (key,failed) -- end of TableRBT curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Test/000077500000000000000000000000001305333611600221475ustar00rootroot00000000000000curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Test/Contract.curry000066400000000000000000000164621305333611600250230ustar00rootroot00000000000000------------------------------------------------------------------------ --- This library defines some auxiliaries to check contracts --- based on specifications or pre- and postconditions provided --- in a Curry module. --- The interface might probably change with the further --- development of the contract implementation. --- --- @author Michael Hanus --- @version May 2016 --- @category general ------------------------------------------------------------------------ module Test.Contract ( withContract1, withContract2 , withContract1ND, withContract2ND , withPreContract1, withPreContract2 , withPostContract0, withPostContract1, withPostContract2 , withPostContract0ND, withPostContract1ND, withPostContract2ND ) where import SetFunctions import Unsafe(trace) --------------------------------------------------------------------------- -- Report the result of checking the pre/postconditions. -- The first argument is a tag (the name of the operation). -- The second argument is unified with () (used by enforceable constraints). -- The third argument is a Boolean result that must not be False for -- a satisfied condition. -- The fourth argument is a string describing the context (arguments,result). checkPre :: String -> Bool -> String -> Bool checkPre fname result arg = case result of True -> True False -> traceLines ["Precondition of "++fname++" violated for:",arg] (error "Execution aborted due to contract violation!") checkPreND :: String -> Values Bool -> String -> Bool checkPreND fname result arg = case False `valueOf` result of True -> traceLines ["Precondition of "++fname++" violated for:",arg] (error "Execution aborted due to contract violation!") False -> True checkPost :: String -> Bool -> String -> Bool checkPost fname result arg = case result of True -> True False -> traceLines ["Postcondition of "++fname++" violated "++ "for:", arg] (error "Execution aborted due to contract violation!") checkPostND :: String -> Values Bool -> String -> Bool checkPostND fname result arg = case False `valueOf` result of True -> traceLines ["Postcondition of "++fname++" violated "++ "for:", arg] (error "Execution aborted due to contract violation!") False -> True -- print some lines of output on stderr with flushing after each line traceLines :: [String] -> a -> a traceLines ls x = trace (unlines ls) x -- show operation used to show argument or result terms to the user: -- Currently, we use Prelude.show but this has the risk that it suspends -- or loops. showATerm :: a -> String showATerm = show -- or Unsafe.showAnyTerm -- --------------------------------------------------------------------------- -- Combinators for checking of contracts having pre- and postconditions withContract1 :: String -> (a -> Bool) -> (a -> b -> Bool) -> (b -> b) -> (a -> b) -> a -> b withContract1 fname precond postcond postobserve fun arg | checkPre fname (precond arg) (showATerm arg) &> checkPost fname (postcond arg result) (unwords [showATerm arg, "->", showATerm (postobserve result)]) = result where result = fun arg withContract1ND :: String -> (a -> Values Bool) -> (a -> b -> Values Bool) -> (b -> b) -> (a -> b) -> a -> b withContract1ND fname precond postcond postobserve fun arg | checkPreND fname (precond arg) (showATerm arg) &> checkPostND fname (postcond arg result) (unwords [showATerm arg, "->", showATerm (postobserve result)]) = result where result = fun arg withContract2 :: String -> (a -> b -> Bool) -> (a -> b -> c -> Bool) -> (c -> c) -> (a -> b -> c) -> a -> b -> c withContract2 fname precond postcond postobserve fun arg1 arg2 | checkPre fname (precond arg1 arg2) (unwords [showATerm arg1,showATerm arg2]) &> checkPost fname (postcond arg1 arg2 result) (unwords [showATerm arg1, showATerm arg2, "->", showATerm (postobserve result)]) = result where result = fun arg1 arg2 withContract2ND :: String -> (a -> b -> Values Bool) -> (a -> b -> c -> Values Bool) -> (c -> c) -> (a -> b -> c) -> a -> b -> c withContract2ND fname precond postcond postobserve fun arg1 arg2 | checkPreND fname (precond arg1 arg2) (unwords [showATerm arg1,showATerm arg2]) &> checkPostND fname (postcond arg1 arg2 result) (unwords [showATerm arg1, showATerm arg2, "->", showATerm (postobserve result)]) = result where result = fun arg1 arg2 --------------------------------------------------------------------------- -- Combinators for checking contracts without postconditions: withPreContract1 :: String -> (a -> Bool) -> (a -> b) -> a -> b withPreContract1 fname precond fun arg | checkPre fname (precond arg) (showATerm arg) = fun arg withPreContract2 :: String -> (a -> b -> Bool) -> (a -> b -> c) -> a -> b -> c withPreContract2 fname precond fun arg1 arg2 | checkPre fname (precond arg1 arg2) (unwords [showATerm arg1,showATerm arg2]) = fun arg1 arg2 --------------------------------------------------------------------------- -- Combinators for checking contracts without preconditions: -- Add postcondition contract to 0-ary operation: withPostContract0 :: String -> (a -> Bool) -> (a -> a) -> a -> a withPostContract0 fname postcond postobserve val | checkPost fname (postcond val) (unwords [showATerm (postobserve val)]) = val -- Add postcondition contract to 0-ary operation: withPostContract0ND :: String -> (a -> Values Bool) -> (a -> a) -> a -> a withPostContract0ND fname postcond postobserve val | checkPostND fname (postcond val) (unwords [showATerm (postobserve val)]) = val withPostContract1 :: String -> (a -> b -> Bool) -> (b -> b) -> (a -> b) -> a -> b withPostContract1 fname postcond postobserve fun arg | checkPost fname (postcond arg result) (unwords [showATerm arg, "->", showATerm (postobserve result)]) = result where result = fun arg withPostContract1ND :: String -> (a -> b -> Values Bool) -> (b -> b) -> (a -> b) -> a -> b withPostContract1ND fname postcond postobserve fun arg | checkPostND fname (postcond arg result) (unwords [showATerm arg, "->", showATerm (postobserve result)]) = result where result = fun arg withPostContract2 :: String -> (a -> b -> c -> Bool) -> (c -> c) -> (a -> b -> c) -> a -> b -> c withPostContract2 fname postcond postobserve fun arg1 arg2 | checkPost fname (postcond arg1 arg2 result) (unwords [showATerm arg1, showATerm arg2, "->", showATerm (postobserve result)]) = result where result = fun arg1 arg2 withPostContract2ND :: String -> (a -> b -> c -> Values Bool) -> (c -> c) -> (a -> b -> c) -> a -> b -> c withPostContract2ND fname postcond postobserve fun arg1 arg2 | checkPostND fname (postcond arg1 arg2 result) (unwords [showATerm arg1, showATerm arg2, "->", showATerm (postobserve result)]) = result where result = fun arg1 arg2 --------------------------------------------------------------------------- curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Test/EasyCheck.curry000066400000000000000000000271001305333611600250740ustar00rootroot00000000000000------------------------------------------------------------------------- --- EasyCheck is a library for automated, property-based testing of --- Curry programs. The ideas behind EasyCheck are described in --- [this paper](http://www-ps.informatik.uni-kiel.de/~sebf/pub/flops08.html) --- The tool `currycheck` automatically executes tests defined with --- this library. EasyCheck supports the definition of unit tests --- (also for I/O operations) and property tests parameterized --- over some arguments. --- --- Note that this module defines the interface of EasyCheck to --- define properties. The operations to actually execute the tests --- are contained in the accompanying library `Test.EasyCheckExec`. --- --- @author Sebastian Fischer (with extensions by Michael Hanus) --- @version June 2016 --- @category general ------------------------------------------------------------------------- module Test.EasyCheck ( -- test specification: PropIO, returns, sameReturns, toError, toIOError, Test, Prop, (==>), for, forAll, test, is, isAlways, isEventually, uniquely, always, eventually, failing, successful, deterministic, (-=-), (<~>), (~>), (<~), (<~~>), (#), (#<), (#>), solutionOf, -- test annotations label, trivial, classify, collect, collectAs, -- enumerating values valuesOfSearchTree, valuesOf, -- for EasyCheckExec Result(..), result, args, updArgs, stamp, testsOf, ioTestOf, forAllValues ) where import Findall (getAllValues) import List ( (\\), delete, diagonal, nub ) import SearchTree ( SearchTree, someSearchTree ) import SearchTreeTraversal infix 1 `is`, `isAlways`, `isEventually` infix 1 -=-, <~>, ~>, <~, <~~>, `trivial`, #, #<, #> infix 1 `returns`, `sameReturns` infixr 0 ==> ------------------------------------------------------------------------- --- Abstract type to represent properties involving IO actions. data PropIO = PropIO (Bool -> String -> IO (Maybe String)) --- The property `returns a x` is satisfied if the execution of the --- I/O action `a` returns the value `x`. returns :: IO a -> a -> PropIO returns act r = PropIO (testIO act (return r)) --- The property `sameReturns a1 a2` is satisfied if the execution of the --- I/O actions `a1` and `a2` return identical values. sameReturns :: IO a -> IO a -> PropIO sameReturns a1 a2 = PropIO (testIO a1 a2) --- The property `toError a` is satisfied if the evaluation of the argument --- to normal form yields an exception. toError :: a -> PropIO toError x = toIOError (getAllValues x >>= \rs -> (id $!! rs) `seq` done) --- The property `toIOError a` is satisfied if the execution of the --- I/O action `a` causes an exception. toIOError :: IO a -> PropIO toIOError act = PropIO (hasIOError act) --- Extracts the tests of an I/O property (used by the test runner). ioTestOf :: PropIO -> (Bool -> String -> IO (Maybe String)) ioTestOf (PropIO t) = t -- Test an IO property, i.e., compare the results of two IO actions. testIO :: IO a -> IO a -> Bool -> String -> IO (Maybe String) testIO act1 act2 quiet msg = catch (do r1 <- act1 r2 <- act2 if r1 == r2 then unless quiet (putStr (msg++": OK\n")) >> return Nothing else do putStrLn $ msg++": FAILED!\nResults: " ++ show (r1,r2) return (Just msg) ) (\err -> do putStrLn $ msg++": EXECUTION FAILURE:\n" ++ showError err return (Just msg) ) -- Test whether an IO action produces an error. hasIOError :: IO a -> Bool -> String -> IO (Maybe String) hasIOError act quiet msg = catch (act >> return (Just msg)) (\_ -> unless quiet (putStr (msg++": OK\n")) >> return Nothing) ------------------------------------------------------------------------- --- Abstract type to represent a single test for a property to be checked. --- A test consists of the result computed for this test, --- the arguments used for this test, and the labels possibly assigned --- to this test by annotating properties. data Test = Test Result [String] [String] --- Data type to represent the result of checking a property. data Result = Undef | Ok | Falsified [String] | Ambigious [Bool] [String] --- Abstract type to represent properties to be checked. --- Basically, it contains all tests to be executed to check the property. data Prop = Prop [Test] --- Extracts the tests of a property (used by the test runner). testsOf :: Prop -> [Test] testsOf (Prop ts) = ts --- An empty test. notest :: Test notest = Test Undef [] [] --- Extracts the result of a test. result :: Test -> Result result (Test r _ _) = r --- Set the result of a test. setResult :: Result -> Test -> Test setResult res (Test _ s a) = Test res a s --- Extracts the arguments of a test. args :: Test -> [String] args (Test _ a _) = a --- Extracts the labels of a test. stamp :: Test -> [String] stamp (Test _ _ s) = s --- Updates the arguments of a test. updArgs :: ([String] -> [String]) -> Test -> Test updArgs upd (Test r a s) = Test r (upd a) s --- Updates the labels of a test. updStamp :: ([String] -> [String]) -> Test -> Test updStamp upd (Test r a s) = Test r a (upd s) -- Test Specification --- Constructs a property to be tested from an arbitrary expression --- (first argument) and a predicate that is applied to the list of --- non-deterministic values. The given predicate determines whether --- the constructed property is satisfied or falsified for the given --- expression. test :: a -> ([a] -> Bool) -> Prop test x f = Prop [setResult res notest] where xs = valuesOf x res = case valuesOf (f xs) of [True] -> Ok [False] -> Falsified (map show xs) bs -> Ambigious bs (map show xs) --- The property `x -=- y` is satisfied if `x` and `y` have deterministic --- values that are equal. (-=-) :: a -> a -> Prop x -=- y = (x,y) `is` uncurry (==) --- The property `x <~> y` is satisfied if the sets of the values of --- `x` and `y` are equal. (<~>) :: a -> a -> Prop x <~> y = test x (isSameSet (valuesOf y)) --- The property `x ~> y` is satisfied if `x` evaluates to every value of `y`. --- Thus, the set of values of `y` must be a subset of the set of values of `x`. (~>) :: a -> a -> Prop x ~> y = test x (isSubsetOf (valuesOf y)) --- The property `x <~ y` is satisfied if `y` evaluates to every value of `x`. --- Thus, the set of values of `x` must be a subset of the set of values of `y`. (<~) :: a -> a -> Prop x <~ y = test x (`isSubsetOf` (valuesOf y)) --- The property `x <~~> y` is satisfied if the multisets of the values of --- `x` and `y` are equal. (<~~>) :: a -> a -> Prop x <~~> y = test x (isSameMSet (valuesOf y)) isSameSet :: [a] -> [a] -> Bool isSameSet xs ys = xs' `subset` ys' && ys' `subset` xs' where xs' = nub xs ys' = nub ys isSubsetOf :: [a] -> [a] -> Bool xs `isSubsetOf` ys = nub xs `subset` ys subset :: [a] -> [a] -> Bool xs `subset` ys = null (xs\\ys) -- compare to lists if they represent the same multi-set isSameMSet :: [a] -> [a] -> Bool isSameMSet [] ys = ys == [] isSameMSet (x:xs) ys | x `elem` ys = isSameMSet xs (delete x ys) | otherwise = False --- A conditional property is tested if the condition evaluates to `True`. (==>) :: Bool -> Prop -> Prop cond ==> p = if True `elem` valuesOf cond then p else Prop [notest] --- `solutionOf p` returns (non-deterministically) a solution --- of predicate `p`. This operation is useful to test solutions --- of predicates. solutionOf :: (a -> Bool) -> a solutionOf pred = pred x &> x where x free --- The property `is x p` is satisfied if `x` has a deterministic value --- which satisfies `p`. is :: a -> (a -> Bool) -> Prop is x f = test x (\xs -> case xs of [y] -> f y _ -> False) --- The property `isAlways x p` is satisfied if all values of `x` satisfy `p`. isAlways :: a -> (a -> Bool) -> Prop isAlways x = test x . all --- The property `isEventually x p` is satisfied if some value of `x` --- satisfies `p`. isEventually :: a -> (a -> Bool) -> Prop isEventually x = test x . any --- The property `uniquely x` is satisfied if `x` has a deterministic value --- which is true. uniquely :: Bool -> Prop uniquely = (`is` id) --- The property `always x` is satisfied if all values of `x` are true. always :: Bool -> Prop always = (`isAlways` id) --- The property `eventually x` is satisfied if some value of `x` is true. eventually :: Bool -> Prop eventually = (`isEventually` id) --- The property `failing x` is satisfied if `x` has no value. failing :: _ -> Prop failing x = test x null --- The property `successful x` is satisfied if `x` has at least one value. successful :: _ -> Prop successful x = test x (not . null) --- The property `deterministic x` is satisfied if `x` has exactly one value. deterministic :: _ -> Prop deterministic x = x `is` const True --- The property `x # n` is satisfied if `x` has `n` values. (#) :: _ -> Int -> Prop x # n = test x ((n==) . length . nub) --- The property `x #< n` is satisfied if `x` has less than `n` values. (#<) :: _ -> Int -> Prop x #< n = test x (( n` is satisfied if `x` has more than `n` values. (#>) :: _ -> Int -> Prop x #> n = test x ((>n) . length . nub) --- The property `for x p` is satisfied if all values `y` of `x` --- satisfy property `p y`. for :: a -> (a -> Prop) -> Prop for x p = forAll (valuesOf x) p --- The property `forAll xs p` is satisfied if all values `x` of the list `xs` --- satisfy property `p x`. forAll :: [a] -> (a -> Prop) -> Prop forAll xs p = forAllValues id xs p --- Only for internal use by the test runner. forAllValues :: (b -> Prop) -> [a] -> (a -> b) -> Prop forAllValues c vals f = Prop $ diagonal [[ updArgs (show y:) t | let Prop ts = c (f y), t <- ts ] | y <- vals ] ------------------------------------------------------------------------- -- Test Annotations --- Assign a label to a property. --- All labeled tests are counted and shown at the end. label :: String -> Prop -> Prop label l (Prop ts) = Prop (map (updStamp (l:)) ts) --- Assign a label to a property if the first argument is `True`. --- All labeled tests are counted and shown at the end. --- Hence, this combinator can be used to classify tests: --- --- multIsComm x y = classify (x<0 || y<0) "Negative" $ x*y -=- y*x --- classify :: Bool -> String -> Prop -> Prop classify True name = label name classify False _ = id --- Assign the label "trivial" to a property if the first argument is `True`. --- All labeled tests are counted and shown at the end. trivial :: Bool -> Prop -> Prop trivial = (`classify` "trivial") --- Assign a label showing the given argument to a property. --- All labeled tests are counted and shown at the end. collect :: a -> Prop -> Prop collect = label . show --- Assign a label showing a given name and the given argument to a property. --- All labeled tests are counted and shown at the end. collectAs :: String -> a -> Prop -> Prop collectAs name = label . ((name++": ")++) . show ------------------------------------------------------------------------- -- Value generation --- Extracts values of a search tree according to a given strategy --- (here: randomized diagonalization of levels with flattening). valuesOfSearchTree :: SearchTree a -> [a] valuesOfSearchTree -- = depthDiag -- = rndDepthDiag 0 -- = levelDiag -- = rndLevelDiag 0 = rndLevelDiagFlat 5 0 -- = allValuesB --- Computes the list of all values of the given argument --- according to a given strategy (here: --- randomized diagonalization of levels with flattening). valuesOf :: a -> [a] valuesOf = valuesOfSearchTree . someSearchTree . (id $##) ------------------------------------------------------------------------- curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Test/EasyCheckExec.curry000066400000000000000000000413251305333611600257060ustar00rootroot00000000000000------------------------------------------------------------------------- --- EasyCheck is a library for automated, property-based testing of --- Curry programs. The ideas behind EasyCheck are described in --- [this paper](http://www-ps.informatik.uni-kiel.de/~sebf/pub/flops08.html) --- This module implements the operations to actually execute --- the tests. --- --- @author Sebastian Fischer (with extensions by Michael Hanus) --- @version June 2016 --- @category general ------------------------------------------------------------------------- module Test.EasyCheckExec ( -- configurations Config(..), verboseConfig, quietConfig, easyConfig, setMaxTest, setMaxFail, -- test functions checkWithValues0, checkWithValues1, checkWithValues2, checkWithValues3, checkWithValues4, checkWithValues5, check0, check1, check2, check3, check4, check5, easyCheck0, easyCheck1, easyCheck2, easyCheck3, easyCheck4, easyCheck5, verboseCheck0, verboseCheck1, verboseCheck2, verboseCheck3, verboseCheck4, verboseCheck5, --easyCheck', easyCheck1', easyCheck2', easyCheck3', easyCheck4', easyCheck5', -- operations used by the CurryCheck tool checkPropWithMsg, checkPropIOWithMsg ) where import AllSolutions ( getAllValues ) import Distribution ( curryCompiler ) import IO ( hFlush, stdout ) import List ( group, intersperse, nub ) import Sort ( leqList, leqString, sortBy ) import Test.EasyCheck ------------------------------------------------------------------------- --- The configuration of property testing. --- The configuration contains --- * the maximum number of tests, --- * the maximum number of condition failures before giving up, --- * an operation that shows the number and arguments of each test, --- * a status whether it should work quietly. data Config = Config { maxTest :: Int , maxFail :: Int , every :: Int -> [String] -> String , isQuiet :: Bool } --- Sets the maximum number of tests in a test configuration. setMaxTest :: Int -> Config -> Config setMaxTest n config = config { maxTest = n } --- Sets the maximum number of condition failures in a test configuration. setMaxFail :: Int -> Config -> Config setMaxFail n config = config { maxFail = n } --- The default configuration for EasyCheck shows and deletes the number --- for each test. easyConfig :: Config easyConfig = Config { maxTest = 100 , maxFail = 10000 , every = (\n _ -> let s = ' ':show (n+1) in s ++ [ chr 8 | _ <- s ]) , isQuiet = False } --- A verbose configuration which shows the arguments of every test. verboseConfig :: Config verboseConfig = easyConfig { every = (\n xs -> show n ++ ":\n" ++ unlines xs) } --- A quiet configuration which shows nothing but failed tests. quietConfig :: Config quietConfig = easyConfig { isQuiet = True, every = (\_ _ -> "") } ------------------------------------------------------------------------- -- Test Functions -- Note that this does not work with PAKCS! However, if CurryCheck is used, -- this operation is not replaced by explicit generator operations. suc :: (a -> Prop) -> (b -> a) -> Prop suc n = forAllValues n (valuesOf unknown) --- Checks a unit test with a given configuration (first argument) --- and a name for the test (second argument). --- Returns a flag whether the test was successful. check0 :: Config -> String -> Prop -> IO Bool check0 = check --- The property `forValues xs p` is satisfied if all values of `xs` --- satisfy property `p x`. forValues :: [a] -> (a -> Prop) -> Prop forValues xs p = forAllValues id xs p --- Checks a unit test with a given configuration (first argument) --- and a name for the test (second argument). --- Returns a flag whether the test was successful. checkWithValues0 :: Config -> String -> Prop -> IO Bool checkWithValues0 = check --- Checks a property parameterized over a single argument --- with a given configuration (first argument), --- a name for the test (second argument), --- and all values given in the third argument. --- Returns a flag whether the test was successful. checkWithValues1 :: Config -> String -> [a] -> (a -> Prop) -> IO Bool checkWithValues1 config msg xs p = check config msg (forValues xs p) --- Checks a property parameterized over two arguments --- with a given configuration (first argument) --- a name for the test (second argument), --- and all values given in the third and fourth argument. --- Returns a flag whether the test was successful. checkWithValues2 :: Config -> String -> [a] -> [b] -> (a -> b -> Prop) -> IO Bool checkWithValues2 config msg xs ys p = check config msg (forValues xs (\x -> forValues ys (p x))) --- Checks a property parameterized over three arguments --- with a given configuration (first argument) --- a name for the test (second argument), --- and all values given in the third, fourth and fifth argument. --- Returns a flag whether the test was successful. checkWithValues3 :: Config -> String -> [a] -> [b] -> [c] -> (a -> b -> c -> Prop) -> IO Bool checkWithValues3 config msg xs ys zs p = check config msg (forValues xs (\x -> forValues ys (\y -> forValues zs (p x y)))) --- Checks a property parameterized over four arguments --- with a given configuration (first argument) --- a name for the test (second argument), --- and all values given in the further arguments. --- Returns a flag whether the test was successful. checkWithValues4 :: Config -> String -> [a] -> [b] -> [c] -> [d] -> (a -> b -> c -> d -> Prop) -> IO Bool checkWithValues4 config msg xs ys zs1 zs2 p = check config msg (forValues xs (\x -> forValues ys (\y -> forValues zs1 (\z1 -> forValues zs2 (p x y z1))))) --- Checks a property parameterized over five arguments --- with a given configuration (first argument) --- a name for the test (second argument), --- and all values given in the further arguments. --- Returns a flag whether the test was successful. checkWithValues5 :: Config -> String -> [a] -> [b] -> [c] -> [d] -> [e] -> (a -> b -> c -> d -> e -> Prop) -> IO Bool checkWithValues5 config msg xs ys zs1 zs2 zs3 p = check config msg (forValues xs (\x -> forValues ys (\y -> forValues zs1 (\z1 -> forValues zs2 (\z2 -> forValues zs3 (p x y z1 z2)))))) --- Checks a property parameterized over a single argument --- with a given configuration (first argument) --- and a name for the test (second argument). --- Returns a flag whether the test was successful. check1 :: Config -> String -> (_ -> Prop) -> IO Bool check1 config msg = check config msg . suc id --- Checks a property parameterized over two arguments --- with a given configuration (first argument) --- and a name for the test (second argument). --- Returns a flag whether the test was successful. check2 :: Config -> String -> (_ -> _ -> Prop) -> IO Bool check2 config msg = check config msg . suc (suc id) --- Checks a property parameterized over three arguments --- with a given configuration (first argument) --- and a name for the test (second argument). --- Returns a flag whether the test was successful. check3 :: Config -> String -> (_ -> _ -> _ -> Prop) -> IO Bool check3 config msg = check config msg . suc (suc (suc id)) --- Checks a property parameterized over four arguments --- with a given configuration (first argument) --- and a name for the test (second argument). --- Returns a flag whether the test was successful. check4 :: Config -> String -> (_ -> _ -> _ -> _ -> Prop) -> IO Bool check4 config msg = check config msg . suc (suc (suc (suc id))) --- Checks a property parameterized over five arguments --- with a given configuration (first argument) --- and a name for the test (second argument). --- Returns a flag whether the test was successful. check5 :: Config -> String -> (_ -> _ -> _ -> _ -> _ -> Prop) -> IO Bool check5 config msg = check config msg . suc (suc (suc (suc (suc id)))) --- Checks a unit test according to the default configuration --- and a name for the test (first argument). --- Returns a flag whether the test was successful. easyCheck0 :: String -> Prop -> IO Bool easyCheck0 = check0 easyConfig --- Checks a property parameterized over a single argument --- according to the default configuration --- and a name for the test (first argument). --- Returns a flag whether the test was successful. easyCheck1 :: String -> (_ -> Prop) -> IO Bool easyCheck1 = check1 easyConfig --- Checks a property parameterized over two arguments --- according to the default configuration --- and a name for the test (first argument). --- Returns a flag whether the test was successful. easyCheck2 :: String -> (_ -> _ -> Prop) -> IO Bool easyCheck2 = check2 easyConfig --- Checks a property parameterized over three arguments --- according to the default configuration --- and a name for the test (first argument). --- Returns a flag whether the test was successful. easyCheck3 :: String -> (_ -> _ -> _ -> Prop) -> IO Bool easyCheck3 = check3 easyConfig --- Checks a property parameterized over four arguments --- according to the default configuration --- and a name for the test (first argument). --- Returns a flag whether the test was successful. easyCheck4 :: String -> (_ -> _ -> _ -> _ -> Prop) -> IO Bool easyCheck4 = check4 easyConfig --- Checks a property parameterized over five arguments --- according to the default configuration --- and a name for the test (first argument). --- Returns a flag whether the test was successful. easyCheck5 :: String -> (_ -> _ -> _ -> _ -> _ -> Prop) -> IO Bool easyCheck5 = check5 easyConfig --- Checks a unit test according to the verbose configuration --- and a name for the test (first argument). --- Returns a flag whether the test was successful. verboseCheck0 :: String -> Prop -> IO Bool verboseCheck0 = check0 verboseConfig --- Checks a property parameterized over a single argument --- according to the verbose configuration --- and a name for the test (first argument). --- Returns a flag whether the test was successful. verboseCheck1 :: String -> (_ -> Prop) -> IO Bool verboseCheck1 = check1 verboseConfig --- Checks a property parameterized over two arguments --- according to the verbose configuration --- and a name for the test (first argument). --- Returns a flag whether the test was successful. verboseCheck2 :: String -> (_ -> _ -> Prop) -> IO Bool verboseCheck2 = check2 verboseConfig --- Checks a property parameterized over three arguments --- according to the verbose configuration --- and a name for the test (first argument). --- Returns a flag whether the test was successful. verboseCheck3 :: String -> (_ -> _ -> _ -> Prop) -> IO Bool verboseCheck3 = check3 verboseConfig --- Checks a property parameterized over four arguments --- according to the verbose configuration --- and a name for the test (first argument). --- Returns a flag whether the test was successful. verboseCheck4 :: String -> (_ -> _ -> _ -> _ -> Prop) -> IO Bool verboseCheck4 = check4 verboseConfig --- Checks a property parameterized over five arguments --- according to the verbose configuration --- and a name for the test (first argument). --- Returns a flag whether the test was successful. verboseCheck5 :: String -> (_ -> _ -> _ -> _ -> _ -> Prop) -> IO Bool verboseCheck5 = check5 verboseConfig check :: Config -> String -> Prop -> IO Bool check config msg ts = tests config msg (testsOf ts) 0 0 [] tests :: Config -> String -> [Test] -> Int -> Int -> [[String]] -> IO Bool tests config msg [] ntest _ stamps = done config (msg ++ ":\n Passed all available tests:") ntest stamps True tests config msg (t:ts) ntest nfail stamps | ntest == maxTest config = done config (msg ++ ":\n OK, passed") ntest stamps True | nfail == maxFail config = done config (msg ++ ":\n Arguments exhausted after") ntest stamps False | otherwise = do putStr (every config ntest (args t)) hFlush stdout case result t of Undef -> tests config msg ts ntest (nfail+1) stamps Ok -> tests config msg ts (ntest+1) nfail (stamp t : stamps) Falsified results -> do putStr $ msg ++ " failed\n" ++ "Falsified by " ++ nth (ntest+1) ++ " test" ++ (if null (args t) then "." else ".\nArguments:") ++ "\n" ++ unlines (args t) ++ if null results then "no result\n" else "Results:\n" ++ unlines (nub results) return False Ambigious bs results -> do putStr $ "Ambigious property yields " ++ show bs ++ " for " ++ nth (ntest+1) ++ " test" ++ (if null (args t) then "." else ".\nArguments:") ++ "\n" ++ unlines (args t) ++ if null results then "no result\n" else "Results:\n" ++ unlines (nub results) return False check' :: Config -> Prop -> Result check' config ts = tests' config (testsOf ts) 0 0 [] tests' :: Config -> [Test] -> Int -> Int -> [[String]] -> Result tests' config (t:ts) ntest nfail stamps | ntest == maxTest config = Ok | nfail == maxFail config = Falsified ["Arguments exhausted after " ++ show ntest ++ " test"] | otherwise = case result t of Undef -> tests' config ts ntest (nfail+1) stamps Ok -> tests' config ts (ntest+1) nfail stamps res -> res easyCheck' :: Prop -> Result easyCheck' = check' easyConfig easyCheck1' :: (_ -> Prop) -> Result easyCheck1' = easyCheck' . suc id easyCheck2' :: (_ -> _ -> Prop) -> Result easyCheck2' = easyCheck' . suc (suc id) easyCheck3' :: (_ -> _ -> _ -> Prop) -> Result easyCheck3' = easyCheck' . suc (suc (suc id)) easyCheck4' :: (_ -> _ -> _ -> _ -> Prop) -> Result easyCheck4' = easyCheck' . suc (suc (suc (suc id))) easyCheck5' :: (_ -> _ -> _ -> _ -> _ -> Prop) -> Result easyCheck5' = easyCheck' . suc (suc (suc (suc (suc id)))) nth :: Int -> String nth n = case n of 1 -> "first" 2 -> "second" 3 -> "third" _ -> show n++ "th" done :: Config -> String -> Int -> [[String]] -> Bool -> IO Bool done config mesg ntest stamps status = do unless (isQuiet config) $ putStr (mesg ++ " " ++ show ntest ++ " test" ++ (if ntest >= 2 then "s" else "") ++ table) return status where table = display . map entry . reverse . sortBy (leqPair (<=) (leqList leqString)) . map pairLength . group . sortBy (leqList leqString) . filter (not . null) $ stamps display [] = ".\n" display [x] = " - " ++ x ++ ".\n" display xs@(_:_:_) = ".\n" ++ unlines (map (++".") xs) pairLength xss@(xs:_) = (length xss,xs) entry (n,xs) = percentage n ntest ++ " " ++ concat (intersperse ", " xs) percentage n _ = let s = show n -- ((100*n)`div`m) in replicate (5-length s) ' ' ++ s -- ++ "%" -- Auxiliary operations leqPair :: (a -> a -> Bool) -> (b -> b -> Bool) -> ((a,b) -> (a,b) -> Bool) leqPair leqa leqb (x1,y1) (x2,y2) | x1 == x2 = leqb y1 y2 | otherwise = leqa x1 x2 ------------------------------------------------------------------------- --- Safely checks a property, i.e., catch all exceptions that might occur --- and return appropriate error message in case of a failed test. checkPropWithMsg :: String -> IO Bool -> IO (Maybe String) checkPropWithMsg msg execprop = catchNDIO msg $ do b <- catch execprop (\e -> putStrLn (msg ++ ": EXECUTION FAILURE:\n" ++ showError e) >> return False) return (if b then Nothing else Just msg) --- Safely checks an IO property, i.e., catch all exceptions that might occur --- and return appropriate error message in case of a failed test. --- This operation is used by the currycheck tool. checkPropIOWithMsg :: Config -> String -> PropIO -> IO (Maybe String) checkPropIOWithMsg config msg p = catchNDIO msg $ (ioTestOf p) (isQuiet config) msg -- Execute I/O action for assertion checking and report any failure -- or non-determinism. catchNDIO :: String -> IO (Maybe String) -> IO (Maybe String) catchNDIO msg testact = if curryCompiler == "kics2" then -- specific handling for KiCS2 since it might report non-det errors -- even if there is only one result value, e.g., in functional patterns getAllValues testact >>= checkIOActions else -- For PAKCS we need a different code since it is more strict -- in encapsulating search catch testact (\e -> putStrLn (msg++": EXECUTION FAILURE: "++showError e) >> return (Just msg)) where checkIOActions results | null results = putStrLn (msg++": FAILURE: computation failed") >> return (Just msg) | not (null (tail results)) = putStrLn (msg++": FAILURE: computation is non-deterministic") >> return (Just msg) | otherwise = head results ------------------------------------------------------------------------- curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Test/Prop.curry000066400000000000000000000245271305333611600241670ustar00rootroot00000000000000------------------------------------------------------------------------- --- This module defines the interface of properties that can be checked --- with the tool `currycheck`, an automatic property-based test tool --- based on the EasyCheck library. --- The ideas behind EasyCheck are described in --- [this paper](http://www-ps.informatik.uni-kiel.de/~sebf/pub/flops08.html) --- The tool `currycheck` automatically executes tests of properties defined --- in this library. CurryCheck supports the definition of unit tests --- (also for I/O operations) and property tests parameterized --- over some arguments. --- --- Basically, this module is a clone of the EasyCheck library --- which contains only the interface and stub versions of some --- operations so that this library does not import any other library. --- This supports the definition of properties in any other module --- (execept for the prelude). --- --- @author Sebastian Fischer (with extensions by Michael Hanus) --- @version June 2016 --- @category general ------------------------------------------------------------------------- module Test.Prop ( -- test specification: PropIO, returns, sameReturns, toError, toIOError, Test, Prop, (==>), for, is, isAlways, isEventually, uniquely, always, eventually, failing, successful, deterministic, (-=-), (<~>), (~>), (<~), (<~~>), (#), (#<), (#>), solutionOf, -- test annotations label, trivial, classify, collect, collectAs, -- enumerating values valuesOf ) where infix 1 `is`, `isAlways`, `isEventually` infix 1 -=-, <~>, ~>, <~, <~~>, `trivial`, #, #<, #> infix 1 `returns`, `sameReturns` infixr 0 ==> ------------------------------------------------------------------------- --- Abstract type to represent properties involving IO actions. data PropIO = PropIO (Bool -> String -> IO (Maybe String)) --- The property `returns a x` is satisfied if the execution of the --- I/O action `a` returns the value `x`. returns :: IO a -> a -> PropIO returns act r = PropIO (testIO act (return r)) --- The property `sameReturns a1 a2` is satisfied if the execution of the --- I/O actions `a1` and `a2` return identical values. sameReturns :: IO a -> IO a -> PropIO sameReturns a1 a2 = PropIO (testIO a1 a2) --- The property `toError a` is satisfied if the evaluation of the argument --- to normal form yields an exception. toError :: a -> PropIO toError _ = propUndefinedError "toError" --- The property `toIOError a` is satisfied if the execution of the --- I/O action `a` causes an exception. toIOError :: IO a -> PropIO toIOError act = PropIO (hasIOError act) --- Extracts the tests of an I/O property (used by the test runner). ioTestOf :: PropIO -> (Bool -> String -> IO (Maybe String)) ioTestOf (PropIO t) = t -- Test an IO property, i.e., compare the results of two IO actions. testIO :: IO a -> IO a -> Bool -> String -> IO (Maybe String) testIO act1 act2 quiet msg = catch (do r1 <- act1 r2 <- act2 if r1 == r2 then unless quiet (putStr (msg++": OK\n")) >> return Nothing else do putStrLn $ msg++": FAILED!\nResults: " ++ show (r1,r2) return (Just msg) ) (\err -> do putStrLn $ msg++": EXECUTION FAILURE:\n" ++ showError err return (Just msg) ) -- Test whether an IO action produces an error. hasIOError :: IO a -> Bool -> String -> IO (Maybe String) hasIOError act quiet msg = catch (act >> return (Just msg)) (\_ -> unless quiet (putStr (msg++": OK\n")) >> return Nothing) ------------------------------------------------------------------------- --- Abstract type to represent a single test for a property to be checked. --- A test consists of the result computed for this test, --- the arguments used for this test, and the labels possibly assigned --- to this test by annotating properties. data Test = Test Result [String] [String] --- Data type to represent the result of checking a property. data Result = Undef | Ok | Falsified [String] | Ambigious [Bool] [String] --- Abstract type to represent properties to be checked. --- Basically, it contains all tests to be executed to check the property. data Prop = Prop [Test] --- Extracts the tests of a property (used by the test runner). testsOf :: Prop -> [Test] testsOf (Prop ts) = ts --- An empty test. notest :: Test notest = Test Undef [] [] --- Extracts the result of a test. result :: Test -> Result result (Test r _ _) = r --- Set the result of a test. setResult :: Result -> Test -> Test setResult res (Test _ s a) = Test res a s --- Extracts the arguments of a test. args :: Test -> [String] args (Test _ a _) = a --- Extracts the labels of a test. stamp :: Test -> [String] stamp (Test _ _ s) = s --- Updates the arguments of a test. updArgs :: ([String] -> [String]) -> Test -> Test updArgs upd (Test r a s) = Test r (upd a) s --- Updates the labels of a test. updStamp :: ([String] -> [String]) -> Test -> Test updStamp upd (Test r a s) = Test r a (upd s) -- Test Specification --- Constructs a property to be tested from an arbitrary expression --- (first argument) and a predicate that is applied to the list of --- non-deterministic values. The given predicate determines whether --- the constructed property is satisfied or falsified for the given --- expression. test :: a -> ([a] -> Bool) -> Prop test x f = Prop [setResult res notest] where xs = valuesOf x res = case valuesOf (f xs) of [True] -> Ok [False] -> Falsified (map show xs) bs -> Ambigious bs (map show xs) --- The property `x -=- y` is satisfied if `x` and `y` have deterministic --- values that are equal. (-=-) :: a -> a -> Prop x -=- y = (x,y) `is` uncurry (==) --- The property `x <~> y` is satisfied if the sets of the values of --- `x` and `y` are equal. (<~>) :: a -> a -> Prop _ <~> _ = propUndefinedError "<~>" --- The property `x ~> y` is satisfied if `x` evaluates to every value of `y`. --- Thus, the set of values of `y` must be a subset of the set of values of `x`. (~>) :: a -> a -> Prop _ ~> _ = propUndefinedError "~>" --- The property `x <~ y` is satisfied if `y` evaluates to every value of `x`. --- Thus, the set of values of `x` must be a subset of the set of values of `y`. (<~) :: a -> a -> Prop _ <~ _ = propUndefinedError "<~" --- The property `x <~~> y` is satisfied if the multisets of the values of --- `x` and `y` are equal. (<~~>) :: a -> a -> Prop _ <~~> _ = propUndefinedError "<~~>" --- A conditional property is tested if the condition evaluates to `True`. (==>) :: Bool -> Prop -> Prop cond ==> p = if True `elem` valuesOf cond then p else Prop [notest] --- `solutionOf p` returns (non-deterministically) a solution --- of predicate `p`. This operation is useful to test solutions --- of predicates. solutionOf :: (a -> Bool) -> a solutionOf pred = pred x &> x where x free --- The property `is x p` is satisfied if `x` has a deterministic value --- which satisfies `p`. is :: a -> (a -> Bool) -> Prop is x f = test x (\xs -> case xs of [y] -> f y _ -> False) --- The property `isAlways x p` is satisfied if all values of `x` satisfy `p`. isAlways :: a -> (a -> Bool) -> Prop isAlways x = test x . all --- The property `isEventually x p` is satisfied if some value of `x` --- satisfies `p`. isEventually :: a -> (a -> Bool) -> Prop isEventually x = test x . any --- The property `uniquely x` is satisfied if `x` has a deterministic value --- which is true. uniquely :: Bool -> Prop uniquely = (`is` id) --- The property `always x` is satisfied if all values of `x` are true. always :: Bool -> Prop always = (`isAlways` id) --- The property `eventually x` is satisfied if some value of `x` is true. eventually :: Bool -> Prop eventually = (`isEventually` id) --- The property `failing x` is satisfied if `x` has no value. failing :: _ -> Prop failing x = test x null --- The property `successful x` is satisfied if `x` has at least one value. successful :: _ -> Prop successful x = test x (not . null) --- The property `deterministic x` is satisfied if `x` has exactly one value. deterministic :: _ -> Prop deterministic x = x `is` const True --- The property `x # n` is satisfied if `x` has `n` values. (#) :: _ -> Int -> Prop _ # _ = propUndefinedError "#" --- The property `x #< n` is satisfied if `x` has less than `n` values. (#<) :: _ -> Int -> Prop _ #< _ = propUndefinedError "#<" --- The property `x #> n` is satisfied if `x` has more than `n` values. (#>) :: _ -> Int -> Prop _ #> _ = propUndefinedError "#>" --- The property `for x p` is satisfied if all values `y` of `x` --- satisfy property `p y`. for :: a -> (a -> Prop) -> Prop for _ _ = propUndefinedError "for" ------------------------------------------------------------------------- -- Test Annotations --- Assign a label to a property. --- All labeled tests are counted and shown at the end. label :: String -> Prop -> Prop label l (Prop ts) = Prop (map (updStamp (l:)) ts) --- Assign a label to a property if the first argument is `True`. --- All labeled tests are counted and shown at the end. --- Hence, this combinator can be used to classify tests: --- --- multIsComm x y = classify (x<0 || y<0) "Negative" $ x*y -=- y*x --- classify :: Bool -> String -> Prop -> Prop classify True name = label name classify False _ = id --- Assign the label "trivial" to a property if the first argument is `True`. --- All labeled tests are counted and shown at the end. trivial :: Bool -> Prop -> Prop trivial = (`classify` "trivial") --- Assign a label showing the given argument to a property. --- All labeled tests are counted and shown at the end. collect :: a -> Prop -> Prop collect = label . show --- Assign a label showing a given name and the given argument to a property. --- All labeled tests are counted and shown at the end. collectAs :: String -> a -> Prop -> Prop collectAs name = label . ((name++": ")++) . show ------------------------------------------------------------------------- -- Value generation --- Computes the list of all values of the given argument --- according to a given strategy (here: --- randomized diagonalization of levels with flattening). valuesOf :: a -> [a] valuesOf = error "Test.Prop.valuesOf undefined. Use Test.EasyCheck to actually run it!" propUndefinedError :: String -> _ propUndefinedError op = error $ "Test.Prop." ++ op ++ " undefined. Use Test.EasyCheck to actually run it!" ------------------------------------------------------------------------- curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Time.curry000066400000000000000000000143251305333611600232210ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for handling date and time information. --- --- @author Michael Hanus --- @version April 2007 --- @category general ------------------------------------------------------------------------------ module Time(ClockTime, CalendarTime(..),ctYear,ctMonth,ctDay,ctHour,ctMin,ctSec,ctTZ, getClockTime,getLocalTime,toUTCTime,toClockTime,toCalendarTime, clockTimeToInt,calendarTimeToString,toDayString,toTimeString, addSeconds,addMinutes,addHours,addDays,addMonths,addYears, daysOfMonth,validDate,compareCalendarTime,compareClockTime, compareDate) where --- ClockTime represents a clock time in some internal representation. data ClockTime = CTime Int --- A calendar time is presented in the following form: --- (CalendarTime year month day hour minute second timezone) --- where timezone is an integer representing the timezone as a difference --- to UTC time in seconds. data CalendarTime = CalendarTime Int Int Int Int Int Int Int --- The year of a calendar time. ctYear :: CalendarTime -> Int ctYear (CalendarTime y _ _ _ _ _ _) = y --- The month of a calendar time. ctMonth :: CalendarTime -> Int ctMonth (CalendarTime _ m _ _ _ _ _) = m --- The day of a calendar time. ctDay :: CalendarTime -> Int ctDay (CalendarTime _ _ d _ _ _ _) = d --- The hour of a calendar time. ctHour :: CalendarTime -> Int ctHour (CalendarTime _ _ _ h _ _ _) = h --- The minute of a calendar time. ctMin :: CalendarTime -> Int ctMin (CalendarTime _ _ _ _ m _ _) = m --- The second of a calendar time. ctSec :: CalendarTime -> Int ctSec (CalendarTime _ _ _ _ _ s _) = s --- The time zone of a calendar time. The value of the --- time zone is the difference to UTC time in seconds. ctTZ :: CalendarTime -> Int ctTZ (CalendarTime _ _ _ _ _ _ tz) = tz --- Returns the current clock time. getClockTime :: IO ClockTime getClockTime external --- Returns the local calendar time. getLocalTime :: IO CalendarTime getLocalTime = do ctime <- getClockTime toCalendarTime ctime --- Transforms a clock time into a unique integer. --- It is ensured that clock times that differs in at least one second --- are mapped into different integers. clockTimeToInt :: ClockTime -> Int clockTimeToInt (CTime i) = i --- Transforms a clock time into a calendar time according to the local time --- (if possible). Since the result depends on the local environment, --- it is an I/O operation. toCalendarTime :: ClockTime -> IO CalendarTime toCalendarTime ctime = prim_toCalendarTime $## ctime prim_toCalendarTime :: ClockTime -> IO CalendarTime prim_toCalendarTime external --- Transforms a clock time into a standard UTC calendar time. --- Thus, this operation is independent on the local time. toUTCTime :: ClockTime -> CalendarTime toUTCTime ctime = prim_toUTCTime $## ctime prim_toUTCTime :: ClockTime -> CalendarTime prim_toUTCTime external --- Transforms a calendar time (interpreted as UTC time) into a clock time. toClockTime :: CalendarTime -> ClockTime toClockTime d = prim_toClockTime $## d prim_toClockTime :: CalendarTime -> ClockTime prim_toClockTime external --- Transforms a calendar time into a readable form. calendarTimeToString :: CalendarTime -> String calendarTimeToString ctime@(CalendarTime y mo d _ _ _ _) = shortMonths!!(mo-1) ++ " " ++ show d ++ " " ++ toTimeString ctime ++ " " ++ show y where shortMonths = ["Jan","Feb","Mar","Apr","May","Jun", "Jul","Aug","Sep","Oct","Nov","Dec"] --- Transforms a calendar time into a string containing the day, e.g., --- "September 23, 2006". toDayString :: CalendarTime -> String toDayString (CalendarTime y mo d _ _ _ _) = longMonths!!(mo-1) ++ " " ++ show d ++ ", " ++ show y where longMonths = ["January","February","March","April","May","June","July", "August","September","October","November","December"] --- Transforms a calendar time into a string containing the time. toTimeString :: CalendarTime -> String toTimeString (CalendarTime _ _ _ h mi s _) = digit2 h ++":"++ digit2 mi ++":"++ digit2 s where digit2 n = if n<10 then ['0',chr(ord '0' + n)] else show n --- Adds seconds to a given time. addSeconds :: Int -> ClockTime -> ClockTime addSeconds n (CTime ctime) = CTime (ctime + n) --- Adds minutes to a given time. addMinutes :: Int -> ClockTime -> ClockTime addMinutes n (CTime ctime) = CTime (ctime + (n*60)) --- Adds hours to a given time. addHours :: Int -> ClockTime -> ClockTime addHours n (CTime ctime) = CTime (ctime + (n*3600)) --- Adds days to a given time. addDays :: Int -> ClockTime -> ClockTime addDays n (CTime ctime) = CTime (ctime + (n*86400)) --- Adds months to a given time. addMonths :: Int -> ClockTime -> ClockTime addMonths n ctime = let CalendarTime y mo d h mi s tz = toUTCTime ctime nmo = (mo-1+n) `mod` 12 + 1 in if nmo>0 then addYears ((mo-1+n) `div` 12) (toClockTime (CalendarTime y nmo d h mi s tz)) else addYears ((mo-1+n) `div` 12 - 1) (toClockTime (CalendarTime y (nmo+12) d h mi s tz)) --- Adds years to a given time. addYears :: Int -> ClockTime -> ClockTime addYears n ctime = if n==0 then ctime else let CalendarTime y mo d h mi s tz = toUTCTime ctime in toClockTime (CalendarTime (y+n) mo d h mi s tz) --- Gets the days of a month in a year. daysOfMonth :: Int -> Int -> Int daysOfMonth mo yr = if mo/=2 then [31,28,31,30,31,30,31,31,30,31,30,31] !! (mo-1) else if yr `mod` 4 == 0 && (yr `mod` 100 /= 0 || yr `mod` 400 == 0) then 29 else 28 --- Is a date consisting of year/month/day valid? validDate :: Int -> Int -> Int -> Bool validDate y m d = m > 0 && m < 13 && d > 0 && d <= daysOfMonth m y --- Compares two dates (don't use it, just for backward compatibility!). compareDate :: CalendarTime -> CalendarTime -> Ordering compareDate = compareCalendarTime --- Compares two calendar times. compareCalendarTime :: CalendarTime -> CalendarTime -> Ordering compareCalendarTime ct1 ct2 = compareClockTime (toClockTime ct1) (toClockTime ct2) --- Compares two clock times. compareClockTime :: ClockTime -> ClockTime -> Ordering compareClockTime (CTime time1) (CTime time2) | time1time2 = GT | otherwise = EQ curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Time.prim_c2p000066400000000000000000000012171305333611600235640ustar00rootroot00000000000000 prim_time prim_getClockTime prim_time prim_toCalendarTime prim_time prim_toUTCTime prim_time prim_toClockTime curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Traversal.curry000066400000000000000000000120611305333611600242610ustar00rootroot00000000000000--------------------------------------------------------------------------- --- Library to support lightweight generic traversals --- through tree-structured data. --- See here --- for a description of the library. --- --- @author Sebastian Fischer --- @version February 2008 --- @category algorithm --------------------------------------------------------------------------- module Traversal ( Traversable, noChildren, children, replaceChildren, mapChildren, family, childFamilies, mapFamily, mapChildFamilies, evalFamily, evalChildFamilies, fold, foldChildren, replaceChildrenIO, mapChildrenIO, mapFamilyIO, mapChildFamiliesIO, evalFamilyIO, evalChildFamiliesIO ) where --- A datatype is Traversable if it defines a function --- that can decompose a value into a list of children of the same type --- and recombine new children to a new value of the original type. --- type Traversable a b = a -> ([b], [b] -> a) --- Traversal function for constructors without children. --- noChildren :: Traversable _ _ noChildren x = ([], const x) --- Yields the children of a value. --- children :: Traversable a b -> a -> [b] children tr = fst . tr --- Replaces the children of a value. --- replaceChildren :: Traversable a b -> a -> [b] -> a replaceChildren tr = snd . tr --- Applies the given function to each child of a value. --- mapChildren :: Traversable a b -> (b -> b) -> a -> a mapChildren tr f x = replaceChildren tr x (map f (children tr x)) --- Computes a list of the given value, its children, those children, etc. --- family :: Traversable a a -> a -> [a] family tr x = familyFL tr x [] --- Computes a list of family members of the children of a value. --- The value and its children can have different types. --- childFamilies :: Traversable a b -> Traversable b b -> a -> [b] childFamilies tra trb x = childFamiliesFL tra trb x [] --- Applies the given function to each member of the family of a value. --- Proceeds bottom-up. --- mapFamily :: Traversable a a -> (a -> a) -> a -> a mapFamily tr f = f . mapChildFamilies tr tr f --- Applies the given function to each member of the families of the children --- of a value. The value and its children can have different types. --- Proceeds bottom-up. --- mapChildFamilies :: Traversable a b -> Traversable b b -> (b -> b) -> a -> a mapChildFamilies tra trb = mapChildren tra . mapFamily trb --- Applies the given function to each member of the family of a value --- as long as possible. On each member of the family of the result the given --- function will yield Nothing. --- Proceeds bottom-up. --- evalFamily :: Traversable a a -> (a -> Maybe a) -> a -> a evalFamily tr f = mapFamily tr g where g x = maybe x (mapFamily tr g) (f x) --- Applies the given function to each member of the families of the children --- of a value as long as possible. --- Similar to 'evalFamily'. --- evalChildFamilies :: Traversable a b -> Traversable b b -> (b -> Maybe b) -> a -> a evalChildFamilies tra trb = mapChildren tra . evalFamily trb --- Implements a traversal similar to a fold with possible default cases. --- fold :: Traversable a a -> (a -> [r] -> r) -> a -> r fold tr f = foldChildren tr tr f f --- Fold the children and combine the results. --- foldChildren :: Traversable a b -> Traversable b b -> (a -> [rb] -> ra) -> (b -> [rb] -> rb) -> a -> ra foldChildren tra trb f g a = f a (map (fold trb g) (children tra a)) --- IO version of replaceChildren --- replaceChildrenIO :: Traversable a b -> a -> IO [b] -> IO a replaceChildrenIO tr = liftIO . replaceChildren tr --- IO version of mapChildren --- mapChildrenIO :: Traversable a b -> (b -> IO b) -> a -> IO a mapChildrenIO tr f a = replaceChildrenIO tr a (mapIO f (children tr a)) --- IO version of mapFamily --- mapFamilyIO :: Traversable a a -> (a -> IO a) -> a -> IO a mapFamilyIO tr f a = mapChildFamiliesIO tr tr f a >>= f --- IO version of mapChildFamilies --- mapChildFamiliesIO :: Traversable a b -> Traversable b b -> (b -> IO b) -> a -> IO a mapChildFamiliesIO tra trb = mapChildrenIO tra . mapFamilyIO trb --- IO version of evalFamily --- evalFamilyIO :: Traversable a a -> (a -> IO (Maybe a)) -> a -> IO a evalFamilyIO tr f = mapFamilyIO tr g where g a = f a >>= maybe (return a) (mapFamilyIO tr g) --- IO version of evalChildFamilies --- evalChildFamiliesIO :: Traversable a b -> Traversable b b -> (b -> IO (Maybe b)) -> a -> IO a evalChildFamiliesIO tra trb = mapChildrenIO tra . evalFamilyIO trb -- implementation of 'family' with functional lists for efficiency reasons type FunList a = [a] -> [a] concatFL :: [FunList a] -> FunList a concatFL [] ys = ys concatFL (x:xs) ys = x (concatFL xs ys) familyFL :: Traversable a a -> a -> FunList a familyFL tr x xs = x : childFamiliesFL tr tr x xs childFamiliesFL :: Traversable a b -> Traversable b b -> a -> FunList b childFamiliesFL tra trb x xs = concatFL (map (familyFL trb) (children tra x)) xs liftIO :: (a -> b) -> IO a -> IO b liftIO f ioa = ioa >>= return . f curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/URL.curry000066400000000000000000000015011305333611600227550ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for dealing with URLs (Uniform Resource Locators). --- --- @author Michael Hanus --- @version November 2003 --- @category web ------------------------------------------------------------------------------ module URL(getContentsOfUrl) where import System import IOExts(readCompleteFile) --- Reads the contents of a document located by a URL. --- This action requires that the program "wget" is in your path, --- otherwise the implementation must be adapted to the local --- installation. getContentsOfUrl :: String -> IO String getContentsOfUrl url = do pid <- getPID let tmpfile = "/tmp/wgeturl."++show pid system ("wget -O "++tmpfile++" \""++url++"\"") cont <- readCompleteFile tmpfile system ("rm -f "++tmpfile) return cont curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Unsafe.curry000066400000000000000000000015411305333611600235400ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library containing unsafe operations. --- These operations should be carefully used (e.g., for testing or debugging). --- These operations should not be used in application programs! --- --- @author Michael Hanus, Bjoern Peemoeller --- @version September 2013 --- @category general ------------------------------------------------------------------------------ module Unsafe ( unsafePerformIO, trace ) where import Char (isSpace) import IO (hPutStrLn, stderr) --- Performs and hides an I/O action in a computation (use with care!). unsafePerformIO :: IO a -> a unsafePerformIO external --- Prints the first argument as a side effect and behaves as identity on the --- second argument. trace :: String -> a -> a trace s x = unsafePerformIO (hPutStrLn stderr s >> return x) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Unsafe.curry.pakcs000066400000000000000000000211161305333611600246400ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library containing unsafe operations. --- These operations should be carefully used (e.g., for testing or debugging). --- These operations should not be used in application programs! --- --- @author Michael Hanus, Bjoern Peemoeller --- @version September 2013 --- @category general ------------------------------------------------------------------------------ module Unsafe ( unsafePerformIO, trace , spawnConstraint, isVar, identicalVar, isGround, compareAnyTerm , showAnyTerm, showAnyQTerm, showAnyExpression, showAnyQExpression , readsAnyUnqualifiedTerm, readAnyUnqualifiedTerm , readsAnyQTerm, readAnyQTerm , readsAnyQExpression, readAnyQExpression ) where import Char (isSpace) import IO (hPutStrLn, stderr) --- Performs and hides an I/O action in a computation (use with care!). unsafePerformIO :: IO a -> a unsafePerformIO external --- Prints the first argument as a side effect and behaves as identity on the --- second argument. trace :: String -> a -> a trace s x = unsafePerformIO (hPutStrLn stderr s >> return x) --- Spawns a constraint and returns the second argument. --- This function can be considered as defined by --- `spawnConstraint c x | c = x`. --- However, the evaluation of the constraint and the right-hand side --- are performed concurrently, i.e., a suspension of the constraint --- does not imply a blocking of the right-hand side and the --- right-hand side might be evaluated before the constraint is successfully --- solved. --- Thus, a computation might return a result even if some of the --- spawned constraints are suspended (use the PAKCS option --- `+suspend` to show such suspended goals). spawnConstraint :: Bool -> a -> a spawnConstraint external --- Tests whether the first argument evaluates to a currently unbound --- variable (use with care!). isVar :: _ -> Bool isVar v = prim_isVar $! v prim_isVar :: _ -> Bool prim_isVar external --- Tests whether both arguments evaluate to the identical currently unbound --- variable (use with care!). --- For instance, identicalVar (id x) (fst (x,1)) evaluates to --- True whereas identicalVar x y and --- let x=1 in identicalVar x x evaluate to False identicalVar :: a -> a -> Bool identicalVar x y = (prim_identicalVar $! y) $! x --- let x=1 in identicalVar x x evaluate to False prim_identicalVar :: a -> a -> Bool prim_identicalVar external --- Tests whether the argument evaluates to a ground value --- (use with care!). isGround :: _ -> Bool isGround v = prim_isGround $!! v prim_isGround :: _ -> Bool prim_isGround external --- Comparison of any data terms, possibly containing variables. --- Data constructors are compared in the order of their definition --- in the datatype declarations and recursively in the arguments. --- Variables are compared in some internal order. compareAnyTerm :: a -> a -> Ordering compareAnyTerm external --- Transforms the normal form of a term into a string representation --- in standard prefix notation. --- Thus, showAnyTerm evaluates its argument to normal form. --- This function is similar to the function ReadShowTerm.showTerm --- but it also transforms logic variables into a string representation --- that can be read back by Unsafe.read(s)AnyUnqualifiedTerm. --- Thus, the result depends on the evaluation and binding status of --- logic variables so that it should be used with care! showAnyTerm :: _ -> String showAnyTerm x = prim_showAnyTerm $!! x prim_showAnyTerm :: _ -> String prim_showAnyTerm external --- Transforms the normal form of a term into a string representation --- in standard prefix notation. --- Thus, showAnyQTerm evaluates its argument to normal form. --- This function is similar to the function ReadShowTerm.showQTerm --- but it also transforms logic variables into a string representation --- that can be read back by Unsafe.read(s)AnyQTerm. --- Thus, the result depends on the evaluation and binding status of --- logic variables so that it should be used with care! showAnyQTerm :: _ -> String showAnyQTerm x = prim_showAnyQTerm $!! x prim_showAnyQTerm :: _ -> String prim_showAnyQTerm external --- Transform a string containing a term in standard prefix notation --- without module qualifiers into the corresponding data term. --- The string might contain logical variable encodings produced by showAnyTerm. --- In case of a successful parse, the result is a one element list --- containing a pair of the data term and the remaining unparsed string. readsAnyUnqualifiedTerm :: [String] -> String -> [(_,String)] readsAnyUnqualifiedTerm [] _ = error "ReadShowTerm.readsAnyUnqualifiedTerm: list of module prefixes is empty" readsAnyUnqualifiedTerm (prefix:prefixes) s = readsAnyUnqualifiedTermWithPrefixes (prefix:prefixes) s readsAnyUnqualifiedTermWithPrefixes :: [String] -> String -> [(_,String)] readsAnyUnqualifiedTermWithPrefixes prefixes s = (prim_readsAnyUnqualifiedTerm $## prefixes) $## s prim_readsAnyUnqualifiedTerm :: [String] -> String -> [(_,String)] prim_readsAnyUnqualifiedTerm external --- Transforms a string containing a term in standard prefix notation --- without module qualifiers into the corresponding data term. --- The string might contain logical variable encodings produced by showAnyTerm. readAnyUnqualifiedTerm :: [String] -> String -> _ readAnyUnqualifiedTerm prefixes s = case result of [(term,tail)] -> if all isSpace tail then term else error ("Unsafe.readAnyUnqualifiedTerm: no parse, unmatched string after term: "++tail) [] -> error "Unsafe.readAnyUnqualifiedTerm: no parse" _ -> error "Unsafe.readAnyUnqualifiedTerm: ambiguous parse" where result = readsAnyUnqualifiedTerm prefixes s --- Transforms a string containing a term in standard prefix notation --- with qualified constructor names into the corresponding data term. --- The string might contain logical variable encodings produced by showAnyQTerm. --- In case of a successful parse, the result is a one element list --- containing a pair of the data term and the remaining unparsed string. readsAnyQTerm :: String -> [(_,String)] readsAnyQTerm s = prim_readsAnyQTerm $## s prim_readsAnyQTerm :: String -> [(_,String)] prim_readsAnyQTerm external --- Transforms a string containing a term in standard prefix notation --- with qualified constructor names into the corresponding data term. --- The string might contain logical variable encodings produced by showAnyQTerm. readAnyQTerm :: String -> _ readAnyQTerm s = case result of [(term,tail)] -> if all isSpace tail then term else error "Unsafe.readAnyQTerm: no parse" [] -> error "Unsafe.readAnyQTerm: no parse" _ -> error "Unsafe.readAnyQTerm: ambiguous parse" where result = readsAnyQTerm s --- Transforms any expression (even not in normal form) into a string representation --- in standard prefix notation without module qualifiers. --- The result depends on the evaluation and binding status of --- logic variables so that it should be used with care! showAnyExpression :: _ -> String showAnyExpression external --- Transforms any expression (even not in normal form) into a string representation --- in standard prefix notation with module qualifiers. --- The result depends on the evaluation and binding status of --- logic variables so that it should be used with care! showAnyQExpression :: _ -> String showAnyQExpression external --- Transforms a string containing an expression in standard prefix notation --- with qualified constructor names into the corresponding expression. --- The string might contain logical variable and defined function --- encodings produced by showAnyQExpression. --- In case of a successful parse, the result is a one element list --- containing a pair of the expression and the remaining unparsed string. readsAnyQExpression :: String -> [(_,String)] readsAnyQExpression s = prim_readsAnyQExpression $## s prim_readsAnyQExpression :: String -> [(_,String)] prim_readsAnyQExpression external --- Transforms a string containing an expression in standard prefix notation --- with qualified constructor names into the corresponding expression. --- The string might contain logical variable and defined function --- encodings produced by showAnyQExpression. readAnyQExpression :: String -> _ readAnyQExpression s = case result of [(term,tail)] -> if all isSpace tail then term else error "Unsafe.readAnyQExpression: no parse" [] -> error "Unsafe.readAnyQExpression: no parse" _ -> error "Unsafe.readAnyQExpression: ambiguous parse" where result = readsAnyQExpression s curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/Unsafe.prim_c2p000066400000000000000000000035461305333611600241160ustar00rootroot00000000000000 prim_unsafe prim_unsafePerformIO[raw] prim_unsafe prim_spawnConstraint[raw] prim_unsafe prim_isVar prim_unsafe prim_identicalVar prim_unsafe prim_isGround prim_unsafe prim_compareAnyTerm[raw] prim_unsafe prim_showAnyTerm prim_unsafe prim_showAnyQTerm prim_unsafe prim_readsAnyUnqualifiedTerm prim_unsafe prim_readsAnyQTerm prim_unsafe prim_showAnyExpression[raw] prim_unsafe prim_showAnyQExpression[raw] prim_unsafe prim_readsAnyQExpression curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/UnsafeSearchTree.curry000066400000000000000000000243171305333611600255140ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library defines a representation of a search space as --- a tree and various search strategies on this tree. --- This module implements **strong encapsulation** as discussed in --- [this paper](http://www.informatik.uni-kiel.de/~mh/papers/JFLP04_findall.html) --- --- Warning: In contrast to the SearchTree Module, free variables that --- are not bound in the encapsulated expression remain free! --- This may lead to non-determinism if such an escaped --- variable is bound later via pattern matching. --- --- @author Michael Hanus, Bjoern Peemoeller, Fabian Reck --- @version July 2013 --- @category algorithm ------------------------------------------------------------------------------ module UnsafeSearchTree ( SearchTree (..), someSearchTree, getSearchTree , isDefined, showSearchTree, searchTreeSize, isVar, identicalVars, varId , Strategy, dfsStrategy, bfsStrategy, idsStrategy, idsStrategyWith , allValuesDFS, allValuesBFS, allValuesIDS, allValuesIDSwith , ValueSequence, vsToList , getAllValuesWith, someValue, someValueWith ) where import ValueSequence --- A search tree is a value, a failure, or a choice between two search trees. data SearchTree a = Value a | Fail Int | Or (SearchTree a) (SearchTree a) --- Tests whether the argument is a free variable --- This function is only meaningful when applied to --- a part of a result of an encapsulated expression --- if the argument stems from a `Value` node of --- a SearchTree isVar :: a -> Bool isVar x = maybe False (const True) (lookupVarId x) --- Tests whether both arguments are identical free variables. --- This function is only meaningful when applied to --- parts of a result of an encapsulated expression --- if the argument stems from a `Value` node of --- a SearchTree identicalVars :: a -> a -> Bool identicalVars x y = maybe False (\xi -> maybe False (==xi) (lookupVarId y)) (lookupVarId x) --- Returns the unique identifier of a free variable, --- if the argument was not a free variable, otherwise an error is raised. --- This function is only meaningful when applied to --- a part of a result of an encapsulated expression --- if the argument stems from a `Value` node of --- a SearchTree varId :: a -> Int varId x = maybe (error "UnsafeSearchTree.varId: argument not a variable") id (lookupVarId x) --- Returns the unique identifier of a free variable --- or Nothing, if the argument was not a free variable. --- This function is only useful when applied to --- a part of a result of a encapsulated expression --- if the argument stems from a `Value` node of --- a SearchTree lookupVarId :: a -> Maybe Int lookupVarId external type Strategy a = SearchTree a -> ValueSequence a --- Returns the search tree for some expression. getSearchTree :: a -> IO (SearchTree a) getSearchTree x = return (someSearchTree x) --- Internal operation to return the search tree for some expression. --- Note that this operation is not purely declarative since --- the ordering in the resulting search tree depends on the --- ordering of the program rules. someSearchTree :: a -> SearchTree a someSearchTree external --- Returns True iff the argument is is defined, i.e., has a value. isDefined :: a -> Bool isDefined x = hasValue (someSearchTree x) where hasValue y = case y of Value _ -> True Fail _ -> False Or t1 t2 -> hasValue t1 || hasValue t2 --- Shows the search tree as an intended line structure showSearchTree :: SearchTree _ -> String showSearchTree st = showsST [] st "" where -- `showsST ctxt `, where `ctxt` is a stack of boolean flags -- indicating whether we show the last alternative of the respective -- level to enable drawing aesthetical corners showsST ctxt (Value a) = indent ctxt . shows a . nl showsST ctxt (Fail _) = indent ctxt . showChar '!' . nl showsST ctxt (Or t1 t2) = indent ctxt . showChar '?' . nl . showsST (False : ctxt) t1 . showsST (True : ctxt) t2 indent [] = id indent (i:is) = showString (concatMap showIndent $ reverse is) . showChar (if i then llc else lmc) . showString (hbar : " ") where showIndent isLast = (if isLast then ' ' else vbar) : " " vbar = '\x2502' -- vertical bar hbar = '\x2500' -- horizontal bar llc = '\x2514' -- left lower corner lmc = '\x251c' -- left middle corner nl = showChar '\n' shows x = showString (show x) showChar c = (c:) showString s = (s++) -- showSearchTree st = showST 0 st "" -- where -- showST _ (Value a) = showString "Value: " . shows a . nl -- showST _ Fail = showString "Fail" . nl -- showST i (Or t1 t2) = showString "Or " -- . showST i' t1 . tab i' . showST i' t2 -- where i' = i + 1 -- tab j = showString $ replicate (3 * j) ' ' --- Return the size (number of Value/Fail/Or nodes) of the search tree searchTreeSize :: SearchTree _ -> (Int, Int, Int) searchTreeSize (Value _) = (1, 0, 0) searchTreeSize (Fail _) = (0, 1, 0) searchTreeSize (Or t1 t2) = let (v1, f1, o1) = searchTreeSize t1 (v2, f2, o2) = searchTreeSize t2 in (v1 + v2, f1 + f2, o1 + o2 + 1) --- Return all values in a search tree via depth-first search allValuesDFS :: SearchTree a -> [a] allValuesDFS = vsToList . dfsStrategy dfsStrategy :: Strategy a dfsStrategy (Fail d) = failVS d dfsStrategy (Value x) = addVS x emptyVS dfsStrategy (Or x y) = dfsStrategy x |++| dfsStrategy y --- Return all values in a search tree via breadth-first search allValuesBFS :: SearchTree a -> [a] allValuesBFS t = vsToList (bfsStrategy t) children :: [SearchTree a] -> [SearchTree a] children [] = [] children (Fail _:ts) = children ts children (Value _:ts) = children ts children (Or x y:ts) = x:y:children ts values :: [SearchTree a] -> ValueSequence a values [] = emptyVS values (Fail d:ts) = failVS d |++| values ts values (Value x:ts) = addVS x (values ts) values (Or _ _:ts) = values ts allBFS :: [SearchTree a] -> ValueSequence a allBFS [] = emptyVS allBFS (t:ts) = values (t:ts) |++| allBFS (children (t:ts)) bfsStrategy :: Strategy a bfsStrategy t = allBFS [t] --- The default initial search depth for IDS defIDSDepth :: Int defIDSDepth = 100 --- The default increasing function for IDS defIDSInc :: Int -> Int defIDSInc = (2*) --- Return all values in a search tree via iterative-deepening search. allValuesIDS :: SearchTree a -> [a] allValuesIDS t = allValuesIDSwith defIDSDepth defIDSInc t idsStrategy :: Strategy a idsStrategy t = idsStrategyWith defIDSDepth defIDSInc t --- Return the list of all values in a search tree via iterative-deepening search. --- The first argument is the initial depth bound and --- the second argument is a function to increase the depth in each --- iteration. allValuesIDSwith :: Int -> (Int -> Int) -> SearchTree a -> [a] allValuesIDSwith initdepth incrdepth = vsToList . idsStrategyWith initdepth incrdepth --- Return all values in a search tree via iterative-deepening search. --- The first argument is the initial depth bound and --- the second argument is a function to increase the depth in each --- iteration. idsStrategyWith :: Int -> (Int -> Int) -> Strategy a idsStrategyWith initdepth incrdepth st = iterIDS initdepth (collectInBounds 0 initdepth st) where iterIDS _ Nil = emptyVS iterIDS n (Cons x xs) = addVS x (iterIDS n xs) iterIDS n (FCons fd xs) = failVS fd |++| iterIDS n xs iterIDS n Abort = let newdepth = incrdepth n in iterIDS newdepth (collectInBounds n newdepth st) -- Collect solutions within some level bounds in a tree. collectInBounds :: Int -> Int -> SearchTree a -> AbortList a collectInBounds oldbound newbound st = collectLevel newbound st where collectLevel d (Fail fd) = if d 0 then concA (collectLevel (d-1) x) (collectLevel (d-1) y) else Abort -- List containing "aborts" are used to implement the iterative -- depeening strategy: data AbortList a = Nil | Cons a (AbortList a) | FCons Int (AbortList a) | Abort -- Concatenation on abort lists where aborts are moved to the right. concA :: AbortList a -> AbortList a -> AbortList a concA Abort Abort = Abort concA Abort Nil = Abort concA Abort (Cons x xs) = Cons x (concA Abort xs) concA Abort (FCons d xs) = FCons d (concA Abort xs) concA Nil ys = ys concA (Cons x xs) ys = Cons x (concA xs ys) concA (FCons d xs) ys = FCons d (concA xs ys) --- Gets all values of an expression w.r.t. a search strategy. --- A search strategy is an operation to traverse a search tree --- and collect all values, e.g., 'dfsStrategy' or 'bfsStrategy'. --- Conceptually, all values are computed on a copy of the expression, --- i.e., the evaluation of the expression does not share any results. --- Moreover, the evaluation suspends as long as the expression --- contains unbound variables. getAllValuesWith :: Strategy a -> a -> IO [a] getAllValuesWith strategy exp = do t <- getSearchTree exp return (vsToList (strategy t)) --- Returns some value for an expression. --- --- Note that this operation is not purely declarative since --- the computed value depends on the ordering of the program rules. --- Thus, this operation should be used only if the expression --- has a single value. It fails if the expression has no value. someValue :: a -> a someValue = someValueWith bfsStrategy --- Returns some value for an expression w.r.t. a search strategy. --- A search strategy is an operation to traverse a search tree --- and collect all values, e.g., 'dfsStrategy' or 'bfsStrategy'. --- --- Note that this operation is not purely declarative since --- the computed value depends on the ordering of the program rules. --- Thus, this operation should be used only if the expression --- has a single value. It fails if the expression has no value. someValueWith :: Strategy a -> a -> a someValueWith strategy x = head (vsToList (strategy (someSearchTree x))) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/ValueSequence.curry000066400000000000000000000033311305333611600250630ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library defines a data structure for sequence of values. --- It is used in search trees (module `SearchTree`) as well as in --- set functions (module `SetFunctions`). --- Using sequence of values (rather than standard lists of values) --- is necessary to get the behavior of set functions --- w.r.t. finite failures right, as described in the paper --- --- > J. Christiansen, M. Hanus, F. Reck, D. Seidel: --- > A Semantics for Weakly Encapsulated Search in Functional Logic Programs --- > Proc. 15th International Conference on Principles and Practice --- > of Declarative Programming (PPDP'13), pp. 49-60, ACM Press, 2013 --- --- @author Fabian Reck --- @version July 2013 --- @category algorithm ------------------------------------------------------------------------------ module ValueSequence(ValueSequence, emptyVS, addVS, failVS, (|++|), vsToList) where --- A value sequence is an abstract sequence of values. --- It also contains failure elements in order to implement the semantics --- of set functions w.r.t. failures in the intended manner. data ValueSequence _ -- external --- An empty sequence of values. emptyVS :: ValueSequence a emptyVS external --- Adds a value to a sequence of values. addVS :: a -> ValueSequence a -> ValueSequence a addVS external --- Adds a failure to a sequence of values. --- The argument is the encapsulation level of the failure. failVS :: Int -> ValueSequence a failVS external --- Concatenates two sequences of values. (|++|) :: ValueSequence a -> ValueSequence a -> ValueSequence a (|++|) external --- Transforms a sequence of values into a list of values. vsToList :: ValueSequence a -> [a] vsToList external curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/ValueSequence.curry.pakcs000066400000000000000000000042511305333611600261650ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library defines a data structure for sequence of values. --- It is used in search trees (module `SearchTree`) as well as in --- set functions (module `SetFunctions`). --- Using sequence of values (rather than standard lists of values) --- is necessary to get the behavior of set functions --- w.r.t. finite failures right, as described in the paper --- --- > J. Christiansen, M. Hanus, F. Reck, D. Seidel: --- > A Semantics for Weakly Encapsulated Search in Functional Logic Programs --- > Proc. 15th International Conference on Principles and Practice --- > of Declarative Programming (PPDP'13), pp. 49-60, ACM Press, 2013 --- --- Note that this is a simple implementation for PAKCS in order to provide --- some functionality used by other modules. --- In particular, the intended semantics of failures is not provided --- in this implementation. --- --- @author Fabian Reck, Michael Hanus --- @version February 2016 --- @category algorithm ------------------------------------------------------------------------------ module ValueSequence(ValueSequence, emptyVS, addVS, failVS, (|++|), vsToList) where --- A value sequence is an abstract sequence of values. --- It also contains failure elements in order to implement the semantics --- of set functions w.r.t. failures in the intended manner (only in KiCS2). data ValueSequence a = EmptyVS | ConsVS a (ValueSequence a) --- An empty sequence of values. emptyVS :: ValueSequence a emptyVS = EmptyVS --- Adds a value to a sequence of values. addVS :: a -> ValueSequence a -> ValueSequence a addVS = ConsVS --- Adds a failure to a sequence of values. --- The argument is the encapsulation level of the failure. failVS :: Int -> ValueSequence a failVS _ = EmptyVS -- cannot be implemented in PAKCS!" --- Concatenates two sequences of values. (|++|) :: ValueSequence a -> ValueSequence a -> ValueSequence a xs |++| ys = case xs of EmptyVS -> ys ConsVS z zs -> ConsVS z (zs |++| ys) --- Transforms a sequence of values into a list of values. vsToList :: ValueSequence a -> [a] vsToList EmptyVS = [] vsToList (ConsVS x xs) = x : vsToList xs curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/WUI.curry000066400000000000000000001302661305333611600227720ustar00rootroot00000000000000------------------------------------------------------------------------------ --- A library to support the type-oriented construction of Web User Interfaces --- (WUIs). --- --- The ideas behind the application and implementation of WUIs are --- described in a paper that is available via --- [this web page](http://www.informatik.uni-kiel.de/~pakcs/WUI). --- --- @author Michael Hanus --- @version May 2014 --- @category web ------------------------------------------------------------------------------ module WUI(--WuiState,cgiRef2state,state2cgiRef,value2state,state2value, --states2state,state2states,altstate2state,state2altstate, Rendering,WuiSpec, withRendering,withError,withCondition,adaptWSpec,transformWSpec, wHidden,wConstant,wInt, wString,wStringSize,wRequiredString,wRequiredStringSize,wTextArea, wSelect,wSelectInt,wSelectBool,wRadioSelect,wRadioBool,wCheckBool, wMultiCheckSelect, wPair,wTriple,w4Tuple,w5Tuple,w6Tuple,w7Tuple,w8Tuple, w9Tuple,w10Tuple,w11Tuple,w12Tuple, -- these parameterized constructor combinators cause -- non-determinism in KiCS2: wCons2,wCons3,wCons4,wCons5,wCons6,wCons7,wCons8, wCons9,wCons10,wCons11,wCons12, wJoinTuple,wMaybe,wCheckMaybe,wRadioMaybe, wList,wListWithHeadings,wHList,wMatrix,wEither, WTree(..),wTree, WuiHandler,wuiHandler2button, renderTuple,renderTaggedTuple,renderList, mainWUI,wui2html,wuiInForm,wuiWithErrorForm) where import HTML import Read(readNat) import List(elemIndex) import Maybe import Char(isDigit,isSpace) import ReadShowTerm infixl 0 `withRendering` infixl 0 `withError` infixl 0 `withCondition` ------------------------------------------------------------------------------ --- An internal WUI state is used to maintain the cgi references of the input --- fields as a structure that corresponds to the structure of the edit data. data WuiState = Ref CgiRef -- reference to elementary input field | Hidden String -- string representation of a hidden value | CompNode [WuiState] -- composition of trees (substructures) | AltNode (Int,WuiState) -- alternative of trees (union of substructures) cgiRef2state :: CgiRef -> WuiState cgiRef2state cr = Ref cr state2cgiRef :: WuiState -> CgiRef state2cgiRef (Ref cr) = cr value2state :: _ -> WuiState value2state v = Hidden (showQTerm v) state2value :: WuiState -> _ state2value (Hidden s) = readQTerm s states2state :: [WuiState] -> WuiState states2state sts = CompNode sts state2states :: WuiState -> [WuiState] state2states (CompNode sts) = sts altstate2state :: (Int,WuiState) -> WuiState altstate2state alt = AltNode alt state2altstate :: WuiState -> (Int,WuiState) state2altstate (AltNode alt) = alt ------------------------------------------------------------------------------ --- A rendering is a function that combines the visualization of components --- of a data structure into some HTML expression. type Rendering = [HtmlExp] -> HtmlExp --- WuiParams specify the parameters of an individual Wui component type: --- * the standard rendering --- * an error message shown in case of illegal inputs --- * a condition to specify legal input values type WuiParams a = (Rendering, String, a->Bool) renderOf (render,_,_) = render errorOf (_,err,_) = err conditionOf (_,_,c) = c ------------------------------------------------------------------------------ --- The type HtmlSate are values consisting of an HTML expression --- (usually containing some input elements) and a WUI state containing --- references to input elements in the HTML expression. type HtmlState = (HtmlExp,WuiState) ------------------------------------------------------------------------------ --- A handler for a WUI is an event handler for HTML forms possibly with some --- specific code attached (for future extensions). data WuiHandler = WHandler HtmlHandler --- Transform a WUI handler into a submit button with a given label string. wuiHandler2button :: String -> WuiHandler -> HtmlExp wuiHandler2button title (WHandler handler) = button title handler ------------------------------------------------------------------------------ --- The type of WUI specifications. --- The first component are parameters specifying the behavior of this WUI type --- (rendering, error message, and constraints on inputs). --- The second component is a "show" function returning an HTML expression for --- the edit fields and a WUI state containing the CgiRefs to extract --- the values from the edit fields. --- The third component is "read" function to extract the values from --- the edit fields for a given cgi environment (returned as (Just v)). --- If the value is not legal, Nothing is returned. The second component --- of the result contains an HTML edit expression --- together with a WUI state to edit the value again. data WuiSpec a = WuiSpec (WuiParams a) (WuiParams a -> a -> HtmlState) (WuiParams a -> CgiEnv -> WuiState -> (Maybe a,HtmlState)) --- Puts a new rendering function into a WUI specification. withRendering :: WuiSpec a -> Rendering -> WuiSpec a withRendering (WuiSpec (_,errmsg,legal) showhtml readvalue) render = WuiSpec (render,errmsg,legal) showhtml readvalue --- Puts a new error message into a WUI specification. withError :: WuiSpec a -> String -> WuiSpec a withError (WuiSpec (render,_,legal) showhtml readvalue) errmsg = WuiSpec (render,errmsg,legal) showhtml readvalue --- Puts a new condition into a WUI specification. withCondition :: WuiSpec a -> (a -> Bool) -> WuiSpec a withCondition (WuiSpec (render,errmsg,_) showhtml readvalue) legal = (WuiSpec (render,errmsg,legal) showhtml readvalue) --- Transforms a WUI specification from one type to another. transformWSpec :: (a->b,b->a) -> WuiSpec a -> WuiSpec b transformWSpec (a2b,b2a) (WuiSpec wparamsa showhtmla readvaluea) = WuiSpec (transParam b2a wparamsa) (\wparamsb b -> showhtmla (transParam a2b wparamsb) (b2a b)) (\wparamsb env wst -> let (mba,errv) = readvaluea (transParam a2b wparamsb) env wst in (maybe Nothing (Just . a2b) mba, errv)) where transParam :: (b->a) -> WuiParams a -> WuiParams b transParam toa (render,errmsg,legal) = (render,errmsg,legal . toa) --- Adapt a WUI specification to a new type. For this purpose, --- the first argument must be a transformation mapping values --- from the old type to the new type. This function must be bijective --- and operationally invertible (i.e., the inverse must be computable --- by narrowing). Otherwise, use transformWSpec! adaptWSpec :: (a->b) -> WuiSpec a -> WuiSpec b adaptWSpec a2b = transformWSpec (a2b,invert a2b) -- Compute the inverse of a function by exploiting function patterns: invert :: (a->b) -> b -> a invert f = f_invert where local_f x = f x --f_invert (local_f x) = x -- here we use a function pattern f_invert y | (local_f x) =:<= y = x where x free -- the same without fun.pat. ------------------------------------------------------------------------------ -- A collection of basic WUIs and WUI combinators: --- A hidden widget for a value that is not shown in the WUI. --- Usually, this is used in components of larger --- structures, e.g., internal identifiers, data base keys. wHidden :: WuiSpec a wHidden = WuiSpec (head,"?",const True) -- dummy values, not used (\_ v -> (hempty, value2state v)) (\_ _ s -> (Just (state2value s), (hempty,s))) --- A widget for values that are shown but cannot be modified. --- The first argument is a mapping of the value into a HTML expression --- to show this value. wConstant :: (a->HtmlExp) -> WuiSpec a wConstant showhtml = WuiSpec (head,"?",const True) (\wparams v -> ((renderOf wparams) [showhtml v], value2state v)) (\(render,_,_) _ s -> let v = state2value s in (Just v, (render [showhtml v],s))) --- A widget for editing integer values. wInt :: WuiSpec Int wInt = WuiSpec (head,"Illegal integer:",const True) (\wparams v -> intWidget (renderOf wparams) (show v)) (\(render,errmsg,legal) env s -> let input = env (state2cgiRef s) renderr = renderError render errmsg in maybe (Nothing, intWidget renderr input) (\v -> if legal v then (Just v, intWidget render input) else (Nothing, intWidget renderr input)) (readMaybeInt (stripSpaces input))) where intWidget render s = let ref free in (render [textfield ref s `addAttr` ("size","6")], cgiRef2state ref) -- Remove leading and ending spaces in a string. stripSpaces :: String -> String stripSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace -- Read a (possibly negative) integer in a string. -- Return Nothing is this is not an integer string. readMaybeInt :: String -> Maybe Int readMaybeInt "" = Nothing readMaybeInt (v:s) | v=='-' = maybe Nothing (\i->Just (-i)) (acc 0 s) | isDigit v = acc 0 (v:s) | otherwise = Nothing where acc n "" = Just n acc n (c:cs) | isDigit c = acc (10*n + ord c - ord '0') cs | otherwise = Nothing checkLegalInput :: WuiParams a -> (Rendering -> a -> HtmlState) -> a -> (Maybe a,HtmlState) checkLegalInput (render,errmsg,legal) value2widget value = if legal value then (Just value, value2widget render value) else (Nothing, value2widget (renderError render errmsg) value) --- A predefined filter for processing string inputs. --- Here, we replace \r\n by \n: filterStringInput :: String -> String filterStringInput = removeCRs --- Replace all \r\n by \n: removeCRs :: String -> String removeCRs [] = [] removeCRs [c] = [c] removeCRs (c1:c2:cs) = if c1=='\r' && c2=='\n' then '\n' : removeCRs cs else c1 : removeCRs (c2:cs) --- A widget for editing string values. wString :: WuiSpec String wString = wStringAttrs [] --- A widget for editing string values with a size attribute. wStringSize :: Int -> WuiSpec String wStringSize size = wStringAttrs [("size",show size)] --- A widget for editing string values with some attributes for the --- text field. wStringAttrs :: [(String,String)] -> WuiSpec String wStringAttrs attrs = WuiSpec (head, "?", const True) (\wparams v -> stringWidget (renderOf wparams) v) (\wparams env s -> checkLegalInput wparams stringWidget (filterStringInput (env (state2cgiRef s)))) where stringWidget render v = let ref free in (render [foldr (flip addAttr) (textfield ref v) attrs], cgiRef2state ref) --- A widget for editing string values that are required to be non-empty. wRequiredString :: WuiSpec String wRequiredString = wString `withError` "Missing input:" `withCondition` (not . null) --- A widget with a size attribute for editing string values --- that are required to be non-empty. wRequiredStringSize :: Int -> WuiSpec String wRequiredStringSize size = wStringSize size `withError` "Missing input:" `withCondition` (not . null) --- A widget for editing string values in a text area. --- The argument specifies the height and width of the text area. wTextArea :: (Int,Int) -> WuiSpec String wTextArea dims = WuiSpec (head, "?", const True) (\wparams v -> textareaWidget (renderOf wparams) v) (\wparams env s -> checkLegalInput wparams textareaWidget (filterStringInput (env (state2cgiRef s)))) where textareaWidget render v = let ref free in (render [textarea ref dims v], cgiRef2state ref) --- A widget to select a value from a given list of values. --- The current value should be contained in the value list and is preselected. --- The first argument is a mapping from values into strings to be shown --- in the selection widget. wSelect :: (a->String) -> [a] -> WuiSpec a wSelect showelem selset = WuiSpec (head,"?",const True) (\wparams v -> selWidget (renderOf wparams) v) (\wparams env s -> checkLegalInput wparams selWidget (selset !! readNat (env (state2cgiRef s)))) where selWidget render v = let ref free idx = elemIndex v selset namevalues = zip (map showelem selset) (map show [0..]) in (render [maybe (selection ref namevalues) (\i -> selectionInitial ref namevalues i) idx], cgiRef2state ref) --- A widget to select a value from a given list of integers (provided as --- the argument). --- The current value should be contained in the value list and is preselected. wSelectInt :: [Int] -> WuiSpec Int wSelectInt = wSelect show --- A widget to select a Boolean value via a selection box. --- The arguments are the strings that are shown for the values --- True and False in the selection box, respectively. --- @param true - string for selection of True --- @param false - string for selection of False --- @return a WUI specification for a Boolean selection widget wSelectBool :: String -> String -> WuiSpec Bool wSelectBool true false = wSelect (\b->if b then true else false) [True,False] --- A widget to select a Boolean value via a check box. --- The first argument are HTML expressions that are shown after the --- check box. The result is True if the box is checked. wCheckBool :: [HtmlExp] -> WuiSpec Bool wCheckBool hexps = WuiSpec (head, "?", const True) (\wparams v -> checkWidget (renderOf wparams) v) (\wparams env s -> checkLegalInput wparams checkWidget (env (state2cgiRef s)=="True")) where checkWidget render v = let ref free in (render [inline ((if v then checkedbox else checkbox) ref "True" : hexps)], cgiRef2state ref) --- A widget to select a list of values from a given list of values --- via check boxes. --- The current values should be contained in the value list and are preselected. --- The first argument is a mapping from values into HTML expressions --- that are shown for each item after the check box. wMultiCheckSelect :: (a->[HtmlExp]) -> [a] -> WuiSpec [a] wMultiCheckSelect showelem selset = WuiSpec (renderTuple, tupleError, const True) (\wparams vs -> checkWidget (renderOf wparams) vs) (\wparams env st -> checkLegalInput wparams checkWidget (concatMap (\ (ref,s) -> if env ref=="True" then [s] else []) (zip (map state2cgiRef (state2states st)) selset))) where checkWidget render vs = let refs = take (length selset) newVars numsetitems = zip refs selset showItem (ref,s) = inline ((if s `elem` vs then checkedbox else checkbox) ref "True" : showelem s) in (render (map showItem numsetitems), states2state (map cgiRef2state refs)) newVars = unknown : newVars --- A widget to select a value from a given list of values via a radio button. --- The current value should be contained in the value list and is preselected. --- The first argument is a mapping from values into HTML expressions --- that are shown for each item after the radio button. wRadioSelect :: (a->[HtmlExp]) -> [a] -> WuiSpec a wRadioSelect showelem selset = WuiSpec (renderTuple, tupleError, const True) (\wparams v -> radioWidget (renderOf wparams) v) (\wparams env s -> checkLegalInput wparams radioWidget (selset !! readNat (env (state2cgiRef s)))) where radioWidget render v = let ref free idx = maybe 0 id (elemIndex v selset) numhitems = zip [0..] (map showelem selset) showItem (i,s) = table [[[(if i==idx then radio_main else radio_other) ref (show i)],s]] in (render (map showItem numhitems), cgiRef2state ref) --- A widget to select a Boolean value via a radio button. --- The arguments are the lists of HTML expressions that are shown after --- the True and False radio buttons, respectively. --- @param true - HTML expressions for True radio button --- @param false - HTML expressions for False radio button --- @return a WUI specification for a Boolean selection widget wRadioBool :: [HtmlExp] -> [HtmlExp] -> WuiSpec Bool wRadioBool truehexps falsehexps = wRadioSelect (\b->if b then truehexps else falsehexps) [True,False] --- WUI combinator for pairs. wPair :: WuiSpec a -> WuiSpec b -> WuiSpec (a,b) -- This simple implementation does not work in KiCS2 due to non-determinism -- cause by functional patterns: -- wPair = wCons2 (\a b -> (a,b)) wPair (WuiSpec rendera showa reada) (WuiSpec renderb showb readb) = WuiSpec (renderTuple, tupleError, const True) showc readc where showc wparams (va,vb) = let (hea,rta) = showa rendera va (heb,rtb) = showb renderb vb in ((renderOf wparams) [hea,heb], states2state [rta,rtb]) readc (render,errmsg,legal) env s = let [ra,rb] = state2states s (rav,(hea,rta)) = reada rendera env ra (rbv,(heb,rtb)) = readb renderb env rb errhexps = [hea,heb] errstate = states2state [rta,rtb] in if rav==Nothing || rbv==Nothing then (Nothing, (render errhexps, errstate)) else let value = (fromJust rav, fromJust rbv) in if legal value then (Just value, (render errhexps, errstate)) else (Nothing, (renderError render errmsg errhexps, errstate)) --- WUI combinator for constructors of arity 2. --- The first argument is the binary constructor. --- The second and third arguments are the WUI specifications --- for the argument types. wCons2 :: (a->b->c) -> WuiSpec a -> WuiSpec b -> WuiSpec c wCons2 cons (WuiSpec rendera showa reada) (WuiSpec renderb showb readb) = WuiSpec (renderTuple, tupleError, const True) showc readc where showc wparams vc | cons va vb =:<= vc = let (hea,rta) = showa rendera va (heb,rtb) = showb renderb vb in ((renderOf wparams) [hea,heb], states2state [rta,rtb]) where va,vb free readc (render,errmsg,legal) env s = let [ra,rb] = state2states s (rav,(hea,rta)) = reada rendera env ra (rbv,(heb,rtb)) = readb renderb env rb errhexps = [hea,heb] errstate = states2state [rta,rtb] in if rav==Nothing || rbv==Nothing then (Nothing, (render errhexps, errstate)) else let value = cons (fromJust rav) (fromJust rbv) in if legal value then (Just value, (render errhexps, errstate)) else (Nothing, (renderError render errmsg errhexps, errstate)) --- WUI combinator for triples. wTriple :: WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec (a,b,c) -- This simple implementation does not work in KiCS2 due to non-determinism -- cause by functional patterns: --wTriple = wCons3 (\a b c -> (a,b,c)) wTriple (WuiSpec rendera showa reada) (WuiSpec renderb showb readb) (WuiSpec renderc showc readc) = WuiSpec (renderTuple, tupleError, const True) showd readd where showd wparams (va,vb,vc) = let (hea,rta) = showa rendera va (heb,rtb) = showb renderb vb (hec,rtc) = showc renderc vc in ((renderOf wparams) [hea,heb,hec], states2state [rta,rtb,rtc]) readd (render,errmsg,legal) env s = let [ra,rb,rc] = state2states s (rav,(hea,rta)) = reada rendera env ra (rbv,(heb,rtb)) = readb renderb env rb (rcv,(hec,rtc)) = readc renderc env rc errhexps = [hea,heb,hec] errstate = states2state [rta,rtb,rtc] in if rav==Nothing || rbv==Nothing || rcv==Nothing then (Nothing, (render errhexps, errstate)) else let value = (fromJust rav, fromJust rbv, fromJust rcv) in if legal value then (Just value, (render errhexps, errstate)) else (Nothing, (renderError render errmsg errhexps, errstate)) --- WUI combinator for constructors of arity 3. --- The first argument is the ternary constructor. --- The further arguments are the WUI specifications for the argument types. wCons3 :: (a->b->c->d) -> WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d wCons3 cons (WuiSpec rendera showa reada) (WuiSpec renderb showb readb) (WuiSpec renderc showc readc) = WuiSpec (renderTuple, tupleError, const True) showd readd where showd wparams vd | cons va vb vc =:<= vd = let (hea,rta) = showa rendera va (heb,rtb) = showb renderb vb (hec,rtc) = showc renderc vc in ((renderOf wparams) [hea,heb,hec], states2state [rta,rtb,rtc]) where va,vb,vc free readd (render,errmsg,legal) env s = let [ra,rb,rc] = state2states s (rav,(hea,rta)) = reada rendera env ra (rbv,(heb,rtb)) = readb renderb env rb (rcv,(hec,rtc)) = readc renderc env rc errhexps = [hea,heb,hec] errstate = states2state [rta,rtb,rtc] in if rav==Nothing || rbv==Nothing || rcv==Nothing then (Nothing, (render errhexps, errstate)) else let value = cons (fromJust rav) (fromJust rbv) (fromJust rcv) in if legal value then (Just value, (render errhexps, errstate)) else (Nothing, (renderError render errmsg errhexps, errstate)) --- WUI combinator for tuples of arity 4. w4Tuple :: WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec (a,b,c,d) --w4Tuple = wCons4 (\a b c d -> (a,b,c,d)) -- does not work for KiCS2 w4Tuple wa wb wc wd = transformWSpec (\ ((a,b),(c,d)) -> (a,b,c,d), \ (a,b,c,d) -> ((a,b),(c,d))) (wJoinTuple (wPair wa wb) (wPair wc wd)) --- WUI combinator for constructors of arity 4. --- The first argument is the ternary constructor. --- The further arguments are the WUI specifications for the argument types. wCons4 :: (a->b->c->d->e) -> WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e wCons4 cons wa wb wc wd = adaptWSpec (\ ((a,b),(c,d)) -> cons a b c d) (wJoinTuple (wPair wa wb) (wPair wc wd)) --- WUI combinator for tuples of arity 5. w5Tuple :: WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec (a,b,c,d,e) --w5Tuple = wCons5 (\a b c d e -> (a,b,c,d,e)) -- does not work for KiCS2 w5Tuple wa wb wc wd we = transformWSpec (\ ((a,b,c),(d,e)) -> (a,b,c,d,e), \ (a,b,c,d,e) -> ((a,b,c),(d,e))) (wJoinTuple (wTriple wa wb wc) (wPair wd we)) --- WUI combinator for constructors of arity 5. --- The first argument is the ternary constructor. --- The further arguments are the WUI specifications for the argument types. wCons5 :: (a->b->c->d->e->f) -> WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f wCons5 cons wa wb wc wd we = adaptWSpec (\ ((a,b,c),(d,e)) -> cons a b c d e) (wJoinTuple (wTriple wa wb wc) (wPair wd we)) --- WUI combinator for tuples of arity 6. w6Tuple :: WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec (a,b,c,d,e,f) --w6Tuple = wCons6 (\a b c d e f -> (a,b,c,d,e,f)) w6Tuple wa wb wc wd we wf = transformWSpec (\ ((a,b,c),(d,e,f)) -> (a,b,c,d,e,f), \ (a,b,c,d,e,f) -> ((a,b,c),(d,e,f))) (wJoinTuple (wTriple wa wb wc) (wTriple wd we wf)) --- WUI combinator for constructors of arity 6. --- The first argument is the ternary constructor. --- The further arguments are the WUI specifications for the argument types. wCons6 :: (a->b->c->d->e->f->g) -> WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g wCons6 cons wa wb wc wd we wf = adaptWSpec (\ ((a,b,c),(d,e,f)) -> cons a b c d e f) (wJoinTuple (wTriple wa wb wc) (wTriple wd we wf)) --- WUI combinator for tuples of arity 7. w7Tuple :: WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec (a,b,c,d,e,f,g) --w7Tuple = wCons7 (\a b c d e f g -> (a,b,c,d,e,f,g)) w7Tuple wa wb wc wd we wf wg = transformWSpec (\ ((a,b,c,d),(e,f,g)) -> (a,b,c,d,e,f,g), \ (a,b,c,d,e,f,g) -> ((a,b,c,d),(e,f,g))) (wJoinTuple (w4Tuple wa wb wc wd) (wTriple we wf wg)) --- WUI combinator for constructors of arity 7. --- The first argument is the ternary constructor. --- The further arguments are the WUI specifications for the argument types. wCons7 :: (a->b->c->d->e->f->g->h) -> WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec h wCons7 cons wa wb wc wd we wf wg = adaptWSpec (\ ((a,b,c,d),(e,f,g)) -> cons a b c d e f g) (wJoinTuple (w4Tuple wa wb wc wd) (wTriple we wf wg)) --- WUI combinator for tuples of arity 8. w8Tuple :: WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec (a,b,c,d,e,f,g,h) --w8Tuple = wCons8 (\a b c d e f g h -> (a,b,c,d,e,f,g,h)) w8Tuple wa wb wc wd we wf wg wh = transformWSpec (\ ((a,b,c,d),(e,f,g,h)) -> (a,b,c,d,e,f,g,h), \ (a,b,c,d,e,f,g,h) -> ((a,b,c,d),(e,f,g,h))) (wJoinTuple (w4Tuple wa wb wc wd) (w4Tuple we wf wg wh)) --- WUI combinator for constructors of arity 8. --- The first argument is the ternary constructor. --- The further arguments are the WUI specifications for the argument types. wCons8 :: (a->b->c->d->e->f->g->h->i) -> WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i wCons8 cons wa wb wc wd we wf wg wh = adaptWSpec (\ ((a,b,c,d),(e,f,g,h)) -> cons a b c d e f g h) (wJoinTuple (w4Tuple wa wb wc wd) (w4Tuple we wf wg wh)) --- WUI combinator for tuples of arity 9. w9Tuple :: WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec (a,b,c,d,e,f,g,h,i) --w9Tuple = wCons9 (\a b c d e f g h i -> (a,b,c,d,e,f,g,h,i)) w9Tuple wa wb wc wd we wf wg wh wi = transformWSpec (\ ((a,b,c,d,e),(f,g,h,i)) -> (a,b,c,d,e,f,g,h,i), \ (a,b,c,d,e,f,g,h,i) -> ((a,b,c,d,e),(f,g,h,i))) (wJoinTuple (w5Tuple wa wb wc wd we) (w4Tuple wf wg wh wi)) --- WUI combinator for constructors of arity 9. --- The first argument is the ternary constructor. --- The further arguments are the WUI specifications for the argument types. wCons9 :: (a->b->c->d->e->f->g->h->i->j) -> WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j wCons9 cons wa wb wc wd we wf wg wh wi = adaptWSpec (\ ((a,b,c,d,e),(f,g,h,i)) -> cons a b c d e f g h i) (wJoinTuple (w5Tuple wa wb wc wd we) (w4Tuple wf wg wh wi)) --- WUI combinator for tuples of arity 10. w10Tuple :: WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j -> WuiSpec (a,b,c,d,e,f,g,h,i,j) --w10Tuple = wCons10 (\a b c d e f g h i j -> (a,b,c,d,e,f,g,h,i,j)) w10Tuple wa wb wc wd we wf wg wh wi wj = transformWSpec (\ ((a,b,c,d,e),(f,g,h,i,j)) -> (a,b,c,d,e,f,g,h,i,j), \ (a,b,c,d,e,f,g,h,i,j) -> ((a,b,c,d,e),(f,g,h,i,j))) (wJoinTuple (w5Tuple wa wb wc wd we) (w5Tuple wf wg wh wi wj)) --- WUI combinator for constructors of arity 10. --- The first argument is the ternary constructor. --- The further arguments are the WUI specifications for the argument types. wCons10 :: (a->b->c->d->e->f->g->h->i->j->k) -> WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j -> WuiSpec k wCons10 cons wa wb wc wd we wf wg wh wi wj = adaptWSpec (\ ((a,b,c,d,e),(f,g,h,i,j)) -> cons a b c d e f g h i j) (wJoinTuple (w5Tuple wa wb wc wd we) (w5Tuple wf wg wh wi wj)) --- WUI combinator for tuples of arity 11. w11Tuple :: WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j -> WuiSpec k -> WuiSpec (a,b,c,d,e,f,g,h,i,j,k) --w11Tuple = wCons11 (\a b c d e f g h i j k -> (a,b,c,d,e,f,g,h,i,j,k)) w11Tuple wa wb wc wd we wf wg wh wi wj wk = transformWSpec (\ ((a,b,c,d,e),(f,g,h,i,j,k)) -> (a,b,c,d,e,f,g,h,i,j,k), \ (a,b,c,d,e,f,g,h,i,j,k) -> ((a,b,c,d,e),(f,g,h,i,j,k))) (wJoinTuple (w5Tuple wa wb wc wd we) (w6Tuple wf wg wh wi wj wk)) --- WUI combinator for constructors of arity 11. --- The first argument is the ternary constructor. --- The further arguments are the WUI specifications for the argument types. wCons11 :: (a->b->c->d->e->f->g->h->i->j->k->l) -> WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j -> WuiSpec k -> WuiSpec l wCons11 cons wa wb wc wd we wf wg wh wi wj wk = adaptWSpec (\ ((a,b,c,d,e),(f,g,h,i,j,k)) -> cons a b c d e f g h i j k) (wJoinTuple (w5Tuple wa wb wc wd we) (w6Tuple wf wg wh wi wj wk)) --- WUI combinator for tuples of arity 12. w12Tuple :: WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j -> WuiSpec k -> WuiSpec l -> WuiSpec (a,b,c,d,e,f,g,h,i,j,k,l) --w12Tuple = wCons12 (\a b c d e f g h i j k l -> (a,b,c,d,e,f,g,h,i,j,k,l)) w12Tuple wa wb wc wd we wf wg wh wi wj wk wl = transformWSpec (\ ((a,b,c,d,e,f),(g,h,i,j,k,l)) -> (a,b,c,d,e,f,g,h,i,j,k,l), \ (a,b,c,d,e,f,g,h,i,j,k,l) -> ((a,b,c,d,e,f),(g,h,i,j,k,l))) (wJoinTuple (w6Tuple wa wb wc wd we wf) (w6Tuple wg wh wi wj wk wl)) --- WUI combinator for constructors of arity 12. --- The first argument is the ternary constructor. --- The further arguments are the WUI specifications for the argument types. wCons12 :: (a->b->c->d->e->f->g->h->i->j->k->l->m) -> WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j -> WuiSpec k -> WuiSpec l -> WuiSpec m wCons12 cons wa wb wc wd we wf wg wh wi wj wk wl = adaptWSpec (\ ((a,b,c,d,e,f),(g,h,i,j,k,l)) -> cons a b c d e f g h i j k l) (wJoinTuple (w6Tuple wa wb wc wd we wf) (w6Tuple wg wh wi wj wk wl)) --- WUI combinator to combine two tuples into a joint tuple. --- It is similar to wPair but renders both components as a single --- tuple provided that the components are already rendered as tuples, --- i.e., by the rendering function renderTuple. --- This combinator is useful to define combinators for large tuples. wJoinTuple :: WuiSpec a -> WuiSpec b -> WuiSpec (a,b) wJoinTuple (WuiSpec rendera showa reada) (WuiSpec renderb showb readb) = WuiSpec (renderTuple, tupleError, const True) showc readc where render2joinrender render [h1,h2] = let h1s = unRenderTuple h1 h2s = unRenderTuple h2 in render (h1s++h2s) showc wparams (va,vb) = let (hea,rta) = showa rendera va (heb,rtb) = showb renderb vb in (render2joinrender (renderOf wparams) [hea,heb],states2state [rta,rtb]) readc (orgrender,errmsg,legal) env s = let [ra,rb] = state2states s (rav,(hea,rta)) = reada rendera env ra (rbv,(heb,rtb)) = readb renderb env rb errhexps = [hea,heb] errstate = states2state [rta,rtb] render = render2joinrender orgrender in if rav==Nothing || rbv==Nothing then (Nothing, (render errhexps, errstate)) else let value = (fromJust rav, fromJust rbv) in if legal value then (Just value, (render errhexps, errstate)) else (Nothing, (renderError render errmsg errhexps, errstate)) --- WUI combinator for list structures where the list elements are vertically --- aligned in a table. wList :: WuiSpec a -> WuiSpec [a] wList (WuiSpec rendera showa reada) = WuiSpec (renderList,"Illegal list:",const True) (\wparams vas -> listWidget (renderOf wparams) (unzip (map (showa rendera) vas))) (\ (render,errmsg,legal) env s -> let rvs = map (reada rendera env) (state2states s) in if Nothing `elem` (map fst rvs) then (Nothing, listWidget render (unzip (map snd rvs))) else let value = map (fromJust . fst) rvs in if legal value then (Just value, listWidget render (unzip (map snd rvs))) else (Nothing, listWidget (renderError render errmsg) (unzip (map snd rvs))) ) where listWidget render (hes,refs) = (render hes, states2state refs) --- Add headings to a standard WUI for list structures: wListWithHeadings :: [String] -> WuiSpec a -> WuiSpec [a] wListWithHeadings headings wspec = wList wspec `withRendering` renderHeadings where renderHeadings hs = addHeadings (renderList hs) (map (\s->[htxt s]) headings) --- WUI combinator for list structures where the list elements are horizontally --- aligned in a table. wHList :: WuiSpec a -> WuiSpec [a] wHList wspec = wList wspec `withRendering` renderTuple --- WUI for matrices, i.e., list of list of elements --- visualized as a matrix. wMatrix :: WuiSpec a -> WuiSpec [[a]] wMatrix wspec = wList (wHList wspec) --- WUI for Maybe values. It is constructed from a WUI for --- Booleans and a WUI for the potential values. Nothing corresponds --- to a selection of False in the Boolean WUI. --- The value WUI is shown after the Boolean WUI. --- @param wspecb - a WUI specification for Boolean values --- @param wspeca - a WUI specification for the type of potential values --- @param def - a default value that is used if the current value is Nothing wMaybe :: WuiSpec Bool -> WuiSpec a -> a -> WuiSpec (Maybe a) wMaybe (WuiSpec paramb showb readb) (WuiSpec parama showa reada) def = WuiSpec (renderTuple, tupleError, const True) (\wparams mbs -> let (heb,rtb) = showb paramb (mbs/=Nothing) (hea,rta) = showa parama (maybe def id mbs) in ((renderOf wparams) [heb,hea], states2state [rtb,rta])) (\ (render,errmsg,legal) env s -> let [rb,ra] = state2states s (rbv,(heb,rtb)) = readb paramb env rb (rav,(hea,rta)) = reada parama env ra errhexps = [heb,hea] errstate = states2state [rtb,rta] in if rbv==Nothing || rav==Nothing then (Nothing, (render errhexps, errstate)) else let value = if fromJust rbv then Just (fromJust rav) else Nothing in if legal value then (Just value, (render errhexps, errstate)) else (Nothing, (renderError render errmsg errhexps, errstate))) --- A WUI for Maybe values where a check box is used to select Just. --- The value WUI is shown after the check box. --- @param wspec - a WUI specification for the type of potential values --- @param hexps - a list of HTML expressions shown after the check box --- @param def - a default value if the current value is Nothing wCheckMaybe :: WuiSpec a -> [HtmlExp] -> a -> WuiSpec (Maybe a) wCheckMaybe wspec exps = wMaybe (wCheckBool exps) wspec --- A WUI for Maybe values where radio buttons are used to switch --- between Nothing and Just. --- The value WUI is shown after the radio button WUI. --- @param wspec - a WUI specification for the type of potential values --- @param hexps - a list of HTML expressions shown after the Nothing button --- @param hexps - a list of HTML expressions shown after the Just button --- @param def - a default value if the current value is Nothing wRadioMaybe :: WuiSpec a -> [HtmlExp] -> [HtmlExp] -> a -> WuiSpec (Maybe a) wRadioMaybe wspec hnothing hjust = wMaybe wBool wspec where wBool = wRadioSelect (\b->if b then hjust else hnothing) [False,True] --- WUI for union types. --- Here we provide only the implementation for Either types --- since other types with more alternatives can be easily reduced to this case. wEither :: WuiSpec a -> WuiSpec b -> WuiSpec (Either a b) wEither (WuiSpec rendera showa reada) (WuiSpec renderb showb readb) = WuiSpec (head, "?", const True) showEither readEither where showEither wparams (Left va) = let (hea,rta) = showa rendera va in ((renderOf wparams) [hea], altstate2state (1,rta)) showEither wparams (Right vb) = let (heb,rtb) = showb renderb vb in ((renderOf wparams) [heb], altstate2state (2,rtb)) readEither (render,errmsg,legal) env s = let (altindex,rab) = state2altstate s in case altindex of 1 -> let (rv,(he,rst)) = reada rendera env rab in checkValue (rv==Nothing) (Left (fromJust rv)) he (altstate2state(1,rst)) 2 -> let (rv,(he,rst)) = readb renderb env rab in checkValue (rv==Nothing) (Right (fromJust rv)) he (altstate2state(2,rst)) where checkValue isnothing value hexp altstate = if isnothing then (Nothing, (render [hexp], altstate)) else if legal value then (Just value, (render [hexp], altstate)) else (Nothing, (renderError render errmsg [hexp], altstate)) --- A simple tree structure to demonstrate the construction of WUIs for tree --- types. data WTree a = WLeaf a | WNode [WTree a] --- WUI for tree types. --- The rendering specifies the rendering of inner nodes. --- Leaves are shown with their default rendering. wTree :: WuiSpec a -> WuiSpec (WTree a) wTree (WuiSpec rendera showa reada) = WuiSpec (renderList, "Illegal tree:", const True) showTree readTree where showTree _ (WLeaf va) = let (hea,rta) = showa rendera va in (hea, altstate2state (1,rta)) showTree wparams (WNode ns) = let (hes,sts) = unzip (map (showTree wparams) ns) in ((renderOf wparams) hes, altstate2state (2,states2state sts)) readTree wpar env s = let (altindex,rab) = state2altstate s in case altindex of 1 -> let (rv,(he,rst)) = reada rendera env rab in checkValue (rv==Nothing) (WLeaf (fromJust rv)) head [he] (altstate2state(1,rst)) 2 -> let rvs = map (readTree wpar env) (state2states rab) in checkValue (Nothing `elem` (map fst rvs)) (WNode (map (fromJust . fst) rvs)) (renderOf wpar) (map (fst . snd) rvs) (altstate2state(2,states2state (map (snd . snd) rvs))) where checkValue isnothing value rendertree hexps altstate = if isnothing then (Nothing, (rendertree hexps, altstate)) else if conditionOf wpar value then (Just value, (rendertree hexps, altstate)) else (Nothing, (renderError rendertree (errorOf wpar) hexps, altstate)) ------------------------------------------------------------------------------- -- Definition of standard rendering functions --- Standard rendering of tuples as a table with a single row. --- Thus, the elements are horizontally aligned. renderTuple :: Rendering renderTuple hexps = table [map (\h->[h]) hexps] --- Inverse operation of renderTuple. If the argument has not the --- shape of the renderTuple output, it is returned unchanged. --- In future versions, this operation is better implemented using --- functional logic features, but currently the encapsulated search --- is a bit weak for this purpose. unRenderTuple :: HtmlExp -> [HtmlExp] unRenderTuple hexp = if isTupleTable hexp then getTupleTableElems hexp else [hexp] where isTupleTable he = case he of HtmlStruct "table" [] [HtmlStruct "tr" [] tds] -> all isSingleElem tds _ -> False isSingleElem he = case he of HtmlStruct "td" _ [_] -> True _ -> False getTupleTableElems (HtmlStruct "table" [] [HtmlStruct "tr" [] tds]) = map (\ (HtmlStruct "td" _ [e]) -> e) tds -- Standard error message for tuples: tupleError = "Illegal combination:" --- Standard rendering of tuples with a tag for each element. --- Thus, each is preceded by a tag, that is set in bold, and all --- elements are vertically aligned. renderTaggedTuple :: [String] -> Rendering renderTaggedTuple tags hexps = table (map (\(t,h)->[[bold [htxt t]],[h]]) (zip tags hexps)) --- Standard rendering of lists as a table with a row for each item: --- Thus, the elements are vertically aligned. renderList :: Rendering renderList hexps = mergeTableOfTable (table (map (\h->[[h]]) hexps)) `addAttr` ("border","1") -- Combine a rendering with an error message. -- The error message is put as the first row of a table with background color -- yellow. renderError :: Rendering -> String -> Rendering renderError render errmsg hexps = table [[[boldRedTxt errmsg]], [[render hexps]]] `addAttr` ("bgcolor","#ffff00") -- background color: yellow boldRedTxt s = HtmlStruct "font" [("color","#ff0000")] [bold [htxt s]] mergeTableOfTable :: HtmlExp -> HtmlExp mergeTableOfTable (HtmlStruct "table" attrs rows) = HtmlStruct "table" attrs (if all isRowWithSingleTableData rows then map mergeRowWithSingleTableData rows else rows ) isRowWithSingleTableData row = case row of (HtmlStruct "tr" [] [HtmlStruct "td" [] [HtmlStruct "table" _ [HtmlStruct "tr" _ _]]]) -> True _ -> False mergeRowWithSingleTableData (HtmlStruct "tr" [] [HtmlStruct "td" [] [HtmlStruct "table" _ [row]]]) = row ------------------------------------------------------------------------------- -- Main operations to generate HTML structures and handlers from -- WUI specifications: --- Generates an HTML form from a WUI data specification, --- an initial value and an update form. mainWUI :: WuiSpec a -> a -> (a -> IO HtmlForm) -> IO HtmlForm mainWUI wuispec val store = do let (hexp,handler) = wui2html wuispec val store return $ form "WUI" [hexp, breakline, wuiHandler2button "Submit" handler] --- Generates HTML editors and a handler from a WUI data specification, --- an initial value and an update form. wui2html :: WuiSpec a -> a -> (a -> IO HtmlForm) -> (HtmlExp,WuiHandler) wui2html wspec val store = wuiWithErrorForm wspec val store standardErrorForm --- A standard error form for WUIs. standardErrorForm :: HtmlExp -> WuiHandler -> IO HtmlForm standardErrorForm hexp whandler = return $ standardForm "Input error" [hexp, wuiHandler2button "Submit" whandler] --- Puts a WUI into a HTML form containing "holes" for the WUI and the --- handler. wuiInForm :: WuiSpec a -> a -> (a -> IO HtmlForm) -> (HtmlExp -> WuiHandler -> IO HtmlForm) -> IO HtmlForm wuiInForm wspec val store userform = answerForm (wuiWithErrorForm wspec val store userform) where answerForm (hexp,whandler) = userform hexp whandler --- Generates HTML editors and a handler from a WUI data specification, --- an initial value and an update form. In addition to wui2html, --- we can provide a skeleton form used to show illegal inputs. wuiWithErrorForm :: WuiSpec a -> a -> (a -> IO HtmlForm) -> (HtmlExp -> WuiHandler -> IO HtmlForm) -> (HtmlExp,WuiHandler) wuiWithErrorForm wspec val store errorform = showAndReadWUI wspec store errorform (generateWUI wspec val) generateWUI :: WuiSpec a -> a -> (HtmlExp, CgiEnv -> (Maybe a,HtmlState)) generateWUI (WuiSpec wparams showhtml readval) val = hst2result (showhtml wparams val) where hst2result (htmledits,wstate) = (htmledits, \env -> readval wparams env wstate) showAndReadWUI :: WuiSpec a -> (a -> IO HtmlForm) -> (HtmlExp -> WuiHandler -> IO HtmlForm) -> (HtmlExp,CgiEnv -> (Maybe a,HtmlState)) -> (HtmlExp,WuiHandler) showAndReadWUI wspec store errorform (htmledits,readenv) = (htmledits, WHandler (htmlhandler wspec)) where htmlhandler wui@(WuiSpec wparams _ readval) env = let (mbnewval, (htmlerrform,errwstate)) = readenv env in maybe (let (errhexp,errhdl) = showAndReadWUI wui store errorform (htmlerrform, \errenv -> readval wparams errenv errwstate) in errorform errhexp errhdl) (\newval -> seq (normalForm newval) -- to strip off unused lvars (store newval)) mbnewval -------------------------------------------------------------------------- curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/WUIjs.curry000066400000000000000000002050221305333611600233200ustar00rootroot00000000000000------------------------------------------------------------------------------ --- A library to support the type-oriented construction of Web User Interfaces --- (WUIs). --- --- The ideas behind the application and implementation of WUIs are --- described in a paper that is available via --- [this web page](http://www.informatik.uni-kiel.de/~pakcs/WUI). --- --- In addition to the original library, this version provides also support --- for JavaScript. --- --- @author Michael Hanus --- @version February, 2009 --- @category web ------------------------------------------------------------------------------ module WUIjs(--WuiState,cgiRef2state,state2cgiRef,value2state,state2value, --states2state,state2states,altstate2state,state2altstate, Rendering,WuiSpec, withRendering,withError,withCondition,withConditionJS, adaptWSpec,transformWSpec, wHidden,wConstant,wInt, wString,wStringSize,wRequiredString,wRequiredStringSize,wTextArea, wSelect,wSelectInt,wSelectBool,wRadioSelect,wRadioBool,wCheckBool, wMultiCheckSelect, wPair,wTriple,w4Tuple,w5Tuple,w6Tuple,w7Tuple,w8Tuple, w9Tuple,w10Tuple,w11Tuple,w12Tuple, wCons2,wCons3,wCons4,wCons5,wCons6,wCons7, wCons8,wCons9,wCons10,wCons11,wCons12,wJoinTuple, wMaybe,wCheckMaybe,wRadioMaybe, wList,wListWithHeadings,wHList,wMatrix,wEither, WTree(..),wTree, WuiHandler,wuiHandler2button, renderTuple,renderTaggedTuple,renderList, mainWUI,wui2html,wuiInForm,wuiWithErrorForm,wuiHandler2button, wCons2JS,wCons3JS,wCons4JS,wCons5JS,wCons6JS,wCons7JS, -- internal... wCons8JS,wCons9JS,wCons10JS,wCons11JS,wCons12JS, -- internal... withConditionJSName -- internal... ) where import HTML import Read(readNat) import List(elemIndex,intersperse) import Maybe import Char(isDigit,isSpace) import ReadShowTerm import JavaScript infixl 0 `withRendering` infixl 0 `withError` infixl 0 `withCondition` infixl 0 `withConditionJS` ------------------------------------------------------------------------------ --- An internal WUI state is used to maintain the cgi references of the input --- fields as a structure that corresponds to the structure of the edit data. --- The last argument is always a JavaScript expression to access the input data --- stored in the form elements. data WuiState = -- reference to elementary input field: Ref CgiRef (Maybe JSExp) -- string representation of a hidden value: | Hidden String (Maybe JSExp) -- composition of trees (substructures): | CompNode [WuiState] (Maybe JSExp) -- alternative of trees (union of substructures): | AltNode (Int,WuiState) (Maybe JSExp) cgiRef2state :: CgiRef -> Maybe JSExp -> WuiState cgiRef2state cr js = Ref cr js state2cgiRef :: WuiState -> CgiRef state2cgiRef (Ref cr _) = cr value2state :: _ -> WuiState value2state v = Hidden (showQTerm v) Nothing state2value :: WuiState -> _ state2value (Hidden s _) = readQTerm s -- Combine several WUI states into a single state. -- The second argument is a string representation of the constructor -- used in the JavaScript processing the of data or Nothing if processing -- by JavaScript is not possible. states2state :: [WuiState] -> Maybe ([JSExp]->JSExp) -> WuiState states2state sts Nothing = CompNode sts Nothing states2state sts (Just jscomb) = CompNode sts (if Nothing `elem` jsOfElems then Nothing else Just (jscomb (map fromJust jsOfElems))) where jsOfElems = map jsAccessToState sts state2states :: WuiState -> [WuiState] state2states (CompNode sts _) = sts altstate2state :: (Int,WuiState) -> WuiState altstate2state alt@(_,st) = AltNode alt (jsAccessToState st) state2altstate :: WuiState -> (Int,WuiState) state2altstate (AltNode alt _) = alt -- Get the JavaScript function to access the current input values. jsAccessToState :: WuiState -> Maybe JSExp jsAccessToState (Ref _ js) = js jsAccessToState (Hidden _ js) = js jsAccessToState (CompNode _ js) = js jsAccessToState (AltNode _ js) = js -- Set the JavaScript function to access the current input values to Nothing: setNoJSAccessInWuiState :: WuiState -> WuiState setNoJSAccessInWuiState (Ref cref _) = Ref cref Nothing setNoJSAccessInWuiState (Hidden s _) = Hidden s Nothing setNoJSAccessInWuiState (CompNode sts _) = CompNode sts Nothing setNoJSAccessInWuiState (AltNode alts _) = AltNode alts Nothing -- Compute a unique name for a state (used to identify error message tables). state2refname :: WuiState -> String state2refname (Ref cref _) = idOfCgiRef cref state2refname (Hidden _ _) = "" state2refname (CompNode ws _) = "comp" ++ concatMap (("_"++) . state2refname) ws state2refname (AltNode (i,s) _) = "alt_" ++ show i ++ "_" ++ state2refname s ------------------------------------------------------------------------------ --- A rendering is a function that combines the visualization of components --- of a data structure into some HTML expression. type Rendering = [HtmlExp] -> HtmlExp --- WuiParams specify the parameters of an individual Wui component type: --- * the standard rendering --- * an error message shown in case of illegal inputs --- * a condition to specify legal input values --- * optionally a JavaScript function name implementing the condition type WuiParams a = (Rendering, String, a->Bool, Maybe String) renderOf (render,_,_,_) = render errorOf (_,err,_,_) = err conditionOf (_,_,c,_) = c jsConditionOf (_,_,_,jsc) = jsc ------------------------------------------------------------------------------ --- The type HtmlState describes a value consisting of an HTML expression --- (usually containing some input elements), possibly a JavaScript expression --- that checks the validity of the value, and a WUI state containing --- references to input elements in the HTML expression. type HtmlState = (HtmlExp, Maybe JSExp, WuiState) ------------------------------------------------------------------------------ --- A handler for a WUI is an event handler for HTML forms possibly with some --- specific JavaScript code attached. data WuiHandler = WHandler HtmlHandler (Maybe JSExp) --- Transform a WUI handler into a submit button with a given label string. wuiHandler2button :: String -> WuiHandler -> HtmlExp wuiHandler2button title (WHandler handler mbjs) = let bt = button title handler in maybe bt (\jse->bt `addAttr` ("onclick","AllowSubmission = " ++ showJSExp jse)) mbjs ------------------------------------------------------------------------------ --- The type of WUI specifications. --- The first component are parameters specifying the behavior of this WUI type --- (rendering, error message, and constraints on inputs). --- The second component is a "show" function returning an HTML expression for --- the edit fields and a WUI state containing the CgiRefs to extract --- the values from the edit fields. --- The third component is "read" function to extract the values from --- the edit fields for a given cgi environment (returned as (Just v)). --- If the value is not legal, Nothing is returned. The second component --- of the result contains an HTML edit expression --- together with a WUI state to edit the value again. data WuiSpec a = WuiSpec (WuiParams a) (WuiParams a -> a -> HtmlState) (WuiParams a -> CgiEnv -> WuiState -> (Maybe a,HtmlState)) --- Puts a new rendering function into a WUI specification. withRendering :: WuiSpec a -> Rendering -> WuiSpec a withRendering (WuiSpec (_,errmsg,legal,jsck) showhtml readvalue) render = WuiSpec (render,errmsg,legal,jsck) showhtml readvalue --- Puts a new error message into a WUI specification. withError :: WuiSpec a -> String -> WuiSpec a withError (WuiSpec (render,_,legal,jsck) showhtml readvalue) errmsg = WuiSpec (render,errmsg,legal,jsck) showhtml readvalue --- Puts a new condition into a WUI specification. withCondition :: WuiSpec a -> (a -> Bool) -> WuiSpec a withCondition (WuiSpec (render,errmsg,_,_) showhtml readvalue) legal = WuiSpec (render,errmsg,legal,Nothing) showhtml readvalue --- Puts a new JavaScript implementation of the condition --- into a WUI specification. withConditionJS :: WuiSpec a -> (a->Bool) -> WuiSpec a withConditionJS (WuiSpec (render,errmsg,_,_) showhtml readvalue) legal = WuiSpec (render,errmsg,legal,Nothing) showhtml readvalue --- Puts a new JavaScript implementation of the condition --- into a WUI specification. withConditionJSName :: WuiSpec a -> (a->Bool,String) -> WuiSpec a withConditionJSName (WuiSpec (render,errmsg,_,_) showhtml readvalue) (legal,jsck) = WuiSpec (render,errmsg,legal,if null jsck then Nothing else Just jsck) showhtml readvalue --- Transforms a WUI specification from one type to another. transformWSpec :: (a->b,b->a) -> WuiSpec a -> WuiSpec b transformWSpec (a2b,b2a) (WuiSpec wparamsa showhtmla readvaluea) = WuiSpec (transParamA2B wparamsa) (\wparamsb b -> setNoJSAccessInHtmlState (showhtmla (transParamB2A wparamsb) (b2a b))) (\wparamsb env wst -> let (mba,errstate) = readvaluea (transParamB2A wparamsb) env wst in (maybe Nothing (Just . a2b) mba, setNoJSAccessInHtmlState errstate)) where transParamA2B :: WuiParams a -> WuiParams b transParamA2B (render,errmsg,legal,_) = -- since we can't transform JS check code for type a into b, we ignore it: (render, errmsg, legal . b2a, Nothing) transParamB2A :: WuiParams b -> WuiParams a transParamB2A (render,errmsg,legal,_) = (render, errmsg, legal . a2b, jsConditionOf wparamsa) -- transform an HtmlState so that the JavaScript access function in -- the corresponding WuiState is set to Nothing (this is necessary since -- the JavaScript access function accesses values of type a and cannot -- be transformed in general to an access function for b values) setNoJSAccessInHtmlState (hexp,jsexp,ws) = (hexp, jsexp, setNoJSAccessInWuiState ws) --- Adapt a WUI specification to a new type. For this purpose, --- the first argument must be a transformation mapping values --- from the old type to the new type. This function must be bijective --- and operationally invertible (i.e., the inverse must be computable --- by narrowing). Otherwise, use transformWSpec! adaptWSpec :: (a->b) -> WuiSpec a -> WuiSpec b adaptWSpec a2b = transformWSpec (a2b,invert a2b) -- Compute the inverse of a function by exploiting function patterns: invert :: (a->b) -> b -> a invert f = f_invert where local_f x = f x --f_invert (local_f x) = x -- here we use a function pattern f_invert y | (local_f x) =:<= y = x where x free -- the same without fun.pat. ------------------------------------------------------------------------------ -- A collection of basic WUIs and WUI combinators: --- A hidden widget for a value that is not shown in the WUI. --- Usually, this is used in components of larger --- structures, e.g., internal identifiers, data base keys. wHidden :: WuiSpec a wHidden = WuiSpec (head,"?",const True,Nothing) -- dummy values, not used (\_ v -> (hempty, Nothing, value2state v)) (\_ _ s -> (Just (state2value s), (hempty,Nothing,s))) --- A widget for values that are shown but cannot be modified. --- The first argument is a mapping of the value into a HTML expression --- to show this value. wConstant :: (a->HtmlExp) -> WuiSpec a wConstant showhtml = WuiSpec (head,"?",const True,Nothing) (\wparams v -> ((renderOf wparams) [showhtml v], Nothing, value2state v)) (\wparams _ s -> let v = state2value s in (Just v, ((renderOf wparams) [showhtml v], Nothing, s))) --- A widget for editing integer values. wInt :: WuiSpec Int wInt = WuiSpec (head,"Illegal integer:",const True,Nothing) (\(render,errmsg,_,jsck) v -> intWidget errmsg jsck render (showInt v)) (\(render,errmsg,legal,jsck) env s -> let input = env (state2cgiRef s) renderr hexps = addErrMsg False False False errmsg "" (render hexps) in maybe (Nothing, intWidget errmsg jsck renderr input) (\v -> if legal v then (Just v, intWidget errmsg jsck render input) else (Nothing, intWidget errmsg jsck renderr input)) (readMaybeInt (stripSpaces input))) where showInt i = if i<0 then '-' : show (-i) else show i intWidget errmsg mbjs render s = (addErrMsg True True False errmsg refname (render [textfield ref s `addAttr` ("size","6") `addAttr` ("onblur",showJSExp jsCheckCall)]), Just jsCheckCall, cgiRef2state ref (Just jsaccess)) where ref free refname = idOfCgiRef ref jsaccess = JSFCall "intValueOf" [JSString refname] parseIntCheckCall = JSFCall "parseIntCheck" [JSString refname] intCheckCall = maybe parseIntCheckCall (\jsf->JSOp "&&" parseIntCheckCall (JSFCall jsf [jsaccess])) mbjs jsCheckCall = JSFCall "setErrorClassName" [JSString refname,intCheckCall] -- Remove leading and ending spaces in a string. stripSpaces :: String -> String stripSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace -- Read a (possibly negative) integer in a string. -- Return Nothing is this is not an integer string. readMaybeInt :: String -> Maybe Int readMaybeInt "" = Nothing readMaybeInt (v:s) | v=='-' = maybe Nothing (\i->Just (-i)) (acc 0 s) | isDigit v = acc 0 (v:s) | otherwise = Nothing where acc n "" = Just n acc n (c:cs) | isDigit c = acc (10*n + ord c - ord '0') cs | otherwise = Nothing checkLegalInput :: WuiParams a -> (String -> Maybe String -> Rendering -> a -> HtmlState) -> Bool -> a -> (Maybe a,HtmlState) checkLegalInput (render,errmsg,legal,jsck) value2widget errorastable value = if legal value then (Just value, value2widget errmsg jsck render value) else (Nothing, value2widget errmsg jsck (\hes -> addErrMsg False False errorastable errmsg "" (render hes)) value) --- A predefined filter for processing string inputs. --- Here, we replace \r\n by \n: filterStringInput :: String -> String filterStringInput = removeCRs --- Replace all \r\n by \n: removeCRs :: String -> String removeCRs [] = [] removeCRs [c] = [c] removeCRs (c1:c2:cs) = if c1=='\r' && c2=='\n' then '\n' : removeCRs cs else c1 : removeCRs (c2:cs) --- A widget for editing string values. wString :: WuiSpec String wString = wStringAttrs [] --- A widget for editing string values with a size attribute. wStringSize :: Int -> WuiSpec String wStringSize size = wStringAttrs [("size",show size)] --- A widget for editing string values with some attributes for the --- text field. wStringAttrs :: [(String,String)] -> WuiSpec String wStringAttrs attrs = WuiSpec (head, "?", const True, Nothing) (\(render,errmsg,_,jsck) v -> stringWidget errmsg jsck render v) (\wparams env s -> checkLegalInput wparams stringWidget False (filterStringInput (env (state2cgiRef s)))) where stringWidget errmsg mbjs render v = (addErrMsg (isJust jsCheckCall) True False errmsg refname (render [foldr (flip addAttr) (textfield ref v) (attrs++onblurAttr)]), jsCheckCall, cgiRef2state ref (Just jsaccess)) where ref free refname = idOfCgiRef ref jsaccess = JSFCall "stringValueOf" [JSString refname] jsCheckCall = maybeJSFun2checkCall refname jsaccess mbjs onblurAttr = maybe [] (\jsc->[("onblur",showJSExp jsc)]) jsCheckCall --- A widget for editing string values that are required to be non-empty. wRequiredString :: WuiSpec String wRequiredString = withConditionJSName (wString `withError` "Missing input:") (not . null, "notEmpty") --- A widget with a size attribute for editing string values --- that are required to be non-empty. wRequiredStringSize :: Int -> WuiSpec String wRequiredStringSize size = withConditionJSName (wStringSize size `withError` "Missing input:") (not . null, "notEmpty") --- A widget for editing string values in a text area. --- The argument specifies the height and width of the text area. wTextArea :: (Int,Int) -> WuiSpec String wTextArea dims = WuiSpec (head, "?", const True, Nothing) (\ (render,errmsg,_,jsck) v -> textareaWidget errmsg jsck render v) (\wparams env s -> checkLegalInput wparams textareaWidget False (filterStringInput (env (state2cgiRef s)))) where textareaWidget errmsg mbjs render v = (addErrMsg (isJust jsCheckCall) True False errmsg refname (render [textarea ref dims v `addAttrs` onblurAttr]), jsCheckCall, cgiRef2state ref (Just jsaccess)) where ref free refname = idOfCgiRef ref jsaccess = JSFCall "stringValueOf" [JSString refname] jsCheckCall = maybeJSFun2checkCall refname jsaccess mbjs onblurAttr = maybe [] (\jsc->[("onblur",showJSExp jsc)]) jsCheckCall --- A widget to select a value from a given list of values. --- The current value should be contained in the value list and is preselected. --- The first argument is a mapping from values into strings to be shown --- in the selection widget. wSelect :: (a->String) -> [a] -> WuiSpec a wSelect showelem selset = WuiSpec (head,"?",const True, Nothing) (\ (render,errmsg,_,jsck) v -> selWidget errmsg jsck render v) (\wparams env s -> checkLegalInput wparams selWidget False (selset !! readNat (env (state2cgiRef s)))) where selWidget _ _ render v = (render [maybe (selection ref namevalues) (\i -> selectionInitial ref namevalues i) idx], Nothing, cgiRef2state ref Nothing) where ref free idx = elemIndex v selset namevalues = zip (map showelem selset) (map show [0..]) --- A widget to select a value from a given list of values that are --- representable in JavaScript. In contrast to the more general combinator --- wSelect, this combinator supports the client-side checking of --- conditions by JavaScipt. --- The current value should be contained in the value list and is preselected. --- The first argument is a mapping from values into strings to be shown --- in the selection widget. --- The second argument maps value into the corresponding JavaScript --- representation. wSelectJS :: (a->String) -> (a->JSExp) -> [a] -> WuiSpec a wSelectJS showelem showjselem selset = WuiSpec (head,"?",const True, Nothing) (\ (render,errmsg,_,jsck) v -> selWidget errmsg jsck render v) (\wparams env s -> checkLegalInput wparams selWidget False (selset !! readNat (env (state2cgiRef s)))) where selWidget errmsg mbjs render v = (addErrMsg (isJust jsCheckCall) True False errmsg refname (render [maybe (selection ref namevalues) (\i -> selectionInitial ref namevalues i) idx]), jsCheckCall, cgiRef2state ref (Just jsaccess)) where ref free refname = idOfCgiRef ref jsaccess = JSFCall "selectValueOf" [JSString refname, JSFCall "new Array" (map showjselem selset)] jsCheckCall = maybeJSFun2checkCall refname jsaccess mbjs idx = elemIndex v selset namevalues = zip (map showelem selset) (map show [0..]) --- A widget to select a value from a given list of integers (provided as --- the argument). --- The current value should be contained in the value list and is preselected. wSelectInt :: [Int] -> WuiSpec Int wSelectInt = wSelectJS show JSInt --- A widget to select a Boolean value via a selection box. --- The arguments are the strings that are shown for the values --- True and False in the selection box, respectively. --- @param true - string for selection of True --- @param false - string for selection of False --- @return a WUI specification for a Boolean selection widget wSelectBool :: String -> String -> WuiSpec Bool wSelectBool true false = wSelectJS (\b->if b then true else false) JSBool [True,False] --- A widget to select a Boolean value via a check box. --- The first argument are HTML expressions that are shown after the --- check box. The result is True if the box is checked. wCheckBool :: [HtmlExp] -> WuiSpec Bool wCheckBool hexps = WuiSpec (head, "?", const True, Nothing) (\ (render,errmsg,_,jsck) v -> checkWidget errmsg jsck render v) (\wparams env s -> checkLegalInput wparams checkWidget False (env (state2cgiRef s)=="True")) where checkWidget errmsg mbjs render v = (addErrMsg (isJust jsCheckCall) True False errmsg refname (render [inline ((if v then checkedbox else checkbox) ref "True" : hexps)]), jsCheckCall, cgiRef2state ref (Just jsaccess)) where ref free refname = idOfCgiRef ref jsaccess = JSFCall "checkBoxValueOf" [JSString refname] jsCheckCall = maybeJSFun2checkCall refname jsaccess mbjs --- A widget to select a list of values from a given list of values --- via check boxes. --- The current values should be contained in the value list --- and are preselected. --- The first argument is a mapping from values into HTML expressions --- that are shown for each item after the check box. wMultiCheckSelect :: (a->[HtmlExp]) -> [a] -> WuiSpec [a] wMultiCheckSelect showelem selset = WuiSpec (renderTuple, tupleError, const True, Nothing) (\ (render,errmsg,_,jsck) vs -> checkWidget errmsg jsck render vs) (\wparams env st -> checkLegalInput wparams checkWidget True (concatMap (\ (ref,s) -> if env ref=="True" then [s] else []) (zip (map state2cgiRef (state2states st)) selset))) where checkWidget _ _ render vs = -- TODO: add JavaScript code let refs = take (length selset) newVars numsetitems = zip refs selset showItem (ref,s) = inline ((if s `elem` vs then checkedbox else checkbox) ref "True" : showelem s) in (render (map showItem numsetitems), Nothing, states2state (map (\cref->cgiRef2state cref Nothing) refs) Nothing) newVars = unknown : newVars --- A widget to select a value from a given list of values via a radio button. --- The current value should be contained in the value list and is preselected. --- The first argument is a mapping from values into HTML expressions --- that are shown for each item after the radio button. wRadioSelect :: (a->[HtmlExp]) -> [a] -> WuiSpec a wRadioSelect showelem selset = WuiSpec (renderTuple, tupleError, const True, Nothing) (\ (render,errmsg,_,jsck) v -> radioWidget errmsg jsck render v) (\wparams env s -> checkLegalInput wparams radioWidget True (selset !! readNat (env (state2cgiRef s)))) where radioWidget _ _ render v = -- TODO: add JavaScript code (render (map showItem numhitems), Nothing, cgiRef2state ref Nothing) where ref free idx = maybe 0 id (elemIndex v selset) numhitems = zip [0..] (map showelem selset) showItem (i,s) = table [[[(if i==idx then radio_main else radio_other) ref (show i)],s]] --- A widget to select a Boolean value via a radio button. --- The arguments are the lists of HTML expressions that are shown after --- the True and False radio buttons, respectively. --- @param true - HTML expressions for True radio button --- @param false - HTML expressions for False radio button --- @return a WUI specification for a Boolean selection widget wRadioBool :: [HtmlExp] -> [HtmlExp] -> WuiSpec Bool wRadioBool truehexps falsehexps = wRadioSelect (\b->if b then truehexps else falsehexps) [True,False] ----------------------------------------------------------------------- -- Auxliary functions used in WUI combinators: --- Translate a (maybe) JavaScript check function into a JavaScript call: maybeJSFun2checkCall _ _ Nothing = Nothing maybeJSFun2checkCall refname jsaccessvalue (Just jsf) = Just (JSFCall "setErrorClassName" [JSString refname, JSFCall jsf [jsaccessvalue]]) --- Conditionally (if first argument is true) adds an error message --- that is initially hidden (if second argument is false). --- If the third argument is true, the error message is framed into a table --- around the HTML expression and the message is shown as the first row of --- the a table, otherwise the error message is shown in front of the --- around an HTML expression. addErrMsg :: Bool -> Bool -> Bool -> String -> String -> HtmlExp -> HtmlExp addErrMsg hasjsck hide astable errmsg refname hexp = if not hide || hasjsck then if astable then table [[[style errmsgclass [htxt errmsg] `addAttrs` msgidattr]],[[hexp]]] `addAttrs` ([("class",tableclass)] ++ tblidattr) else inline [style errmsgclass [htxt errmsg] `addAttrs` msgidattr, hexp] else hexp where msgidattr = if null refname then [] else [("id","MSG_"++refname)] tblidattr = if null refname then [] else [("id",refname)] tableclass = if hide then "wuipassiveerrmsg" else "wuiactiveerrmsg" errmsgclass = if hide then "wuihide" else "wuinohide" -- Tuple constructor of arity n in JavaScript: jsTupleCons n = jsConsTerm ('(' : replicate (n - 1) ',' ++ ")") -- Join a list of input fields (each consisting of HTML expressions, -- JavaScript checks, WUI states) into a single structure accordding -- to the WUI parameters. If the second argument is True, the error message -- is hidden until explicitly displayed by the JavaScript checks. -- The third argument (jscomb) is a JavaScript combinator that combines -- the expressions to access the values of the subfields into an expression -- to access the complete combined value (or Nothing if such a combination -- is not possible) joinSubFields :: WuiParams _ -> Bool -> [(HtmlExp,Maybe JSExp,WuiState)] -> Maybe ([JSExp]->JSExp) -> (HtmlExp,Maybe JSExp,WuiState) joinSubFields (render,errmsg,_,mbjsck) hide subfields jscomb = let (subhexps,subjscks,substates) = unzip3 subfields consstate = states2state substates jscomb refname = state2refname consstate jscall = jsCheckCallFromState consstate mbjsck jscks = catMaybes subjscks in (addErrMsg (isJust jscall) hide True errmsg refname (render subhexps), if null jscks then jscall else Just (maybe (parAndJS jscks) (\jsc->JSOp "&&" (JSOp "&&" (JSFCall "unsetErrorClassName" [JSString refname]) (parAndJS jscks)) jsc) jscall), consstate) where -- generate strict conjunction of non-empty list of JavaScript expressions: parAndJS [j] = j parAndJS (j1:j2:js) = JSFCall "And" [j1,parAndJS (j2:js)] -- Check and join values of subelements. -- If there is an error is some subfield (indicated by the fourth argument), -- return Nothing, otherwise check the combined value. checkAndJoinSubFields wparams subfields jscons errorinsubfields joinvalue = let combine hide = joinSubFields wparams hide subfields jscons in if errorinsubfields then (Nothing, combine True) else if (conditionOf wparams) joinvalue then (Just joinvalue, combine True) else (Nothing, combine False) -- Generate a single structure that is a given alternative of an input field -- (each consisting of an HTML expression, JavaScript check, WUI state) -- accordding to the WUI parameters. -- If the second argument is True, the error message -- is hidden until explicitly displayed by the JavaScript checks. altSubField :: WuiParams _ -> Bool -> HtmlExp -> Maybe JSExp -> (Int,WuiState) -> (HtmlExp,Maybe JSExp,WuiState) altSubField (render,errmsg,_,mbjsck) hide subhexp subjsck altstate = let consstate = altstate2state altstate refname = state2refname consstate jscons = jsCheckCallFromState consstate mbjsck in (addErrMsg (isJust jscons) hide False errmsg refname (render [subhexp]), maybe jscons (\subjs -> Just (maybe subjs (\jsc->JSOp "&&" (JSOp "&&" (JSFCall "unsetErrorClassName" [JSString refname]) subjs) jsc) jscons)) subjsck, consstate) jsCheckCallFromState _ Nothing = Nothing jsCheckCallFromState wstate (Just jsck) = maybe Nothing (\jsstateaccess -> Just (JSFCall "setErrorClassName" [JSString (state2refname wstate), JSFCall jsck [jsstateaccess]])) (jsAccessToState wstate) ------------------------------------------------------------------------- --- WUI combinator to combine two tuples into a joint tuple. --- It is similar to wPair but renders both components as a single --- tuple provided that the components are already rendered as tuples, --- i.e., by the rendering function renderTuple. --- This combinator is useful to define combinators for large tuples. wJoinTuple :: WuiSpec a -> WuiSpec b -> WuiSpec (a,b) wJoinTuple (WuiSpec wparama showa reada) (WuiSpec wparamb showb readb) = WuiSpec (renderTuple, tupleError, const True, Nothing) showc readc where jscons = Just (jsTupleCons 2) render2joinrender render [h1,h2] = let h1s = unRenderTuple h1 h2s = unRenderTuple h2 in render (h1s++h2s) addJoinRender (render,errmsg,legal,jsck) = (render2joinrender render,errmsg,legal,jsck) showc wparams vc | (va,vb) =:<= vc = joinSubFields (addJoinRender wparams) True [showa wparama va, showb wparamb vb] jscons where va,vb free readc wparams env s = let [ra,rb] = state2states s (rav,fielda) = reada wparama env ra (rbv,fieldb) = readb wparamb env rb in checkAndJoinSubFields (addJoinRender wparams) [fielda,fieldb] jscons (rav==Nothing || rbv==Nothing) (fromJust rav, fromJust rbv) --- WUI combinator for pairs. wPair :: WuiSpec a -> WuiSpec b -> WuiSpec (a,b) wPair = wCons2JS (Just (jsTupleCons 2)) (\a b -> (a,b)) --- WUI combinator for constructors of arity 2. --- The first argument is the binary constructor. --- The second and third arguments are the WUI specifications --- for the argument types. wCons2 :: (a->b->c) -> WuiSpec a -> WuiSpec b -> WuiSpec c wCons2 = wCons2JS Nothing wCons2JS jscons cons (WuiSpec wparama showa reada) (WuiSpec wparamb showb readb) = WuiSpec (renderTuple, tupleError, const True, Nothing) showc readc where showc wparams vc | cons va vb =:<= vc = joinSubFields wparams True [showa wparama va, showb wparamb vb] jscons where va,vb free readc wparams env s = let [ra,rb] = state2states s (rav,fielda) = reada wparama env ra (rbv,fieldb) = readb wparamb env rb in checkAndJoinSubFields wparams [fielda,fieldb] jscons (rav==Nothing || rbv==Nothing) (cons (fromJust rav) (fromJust rbv)) --- WUI combinator for triples. wTriple :: WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec (a,b,c) wTriple = wCons3JS (Just (jsTupleCons 3)) (\a b c -> (a,b,c)) --- WUI combinator for constructors of arity 3. --- The first argument is the ternary constructor. --- The further arguments are the WUI specifications for the argument types. wCons3 :: (a->b->c->d) -> WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d wCons3 = wCons3JS Nothing wCons3JS jscons cons (WuiSpec wparama showa reada) (WuiSpec wparamb showb readb) (WuiSpec wparamc showc readc) = WuiSpec (renderTuple, tupleError, const True, Nothing) showd readd where showd wparams vd | cons va vb vc =:<= vd = joinSubFields wparams True [showa wparama va, showb wparamb vb, showc wparamc vc] jscons where va,vb,vc free readd wparams env s = let [ra,rb,rc] = state2states s (rav,fielda) = reada wparama env ra (rbv,fieldb) = readb wparamb env rb (rcv,fieldc) = readc wparamc env rc in checkAndJoinSubFields wparams [fielda,fieldb,fieldc] jscons (rav==Nothing || rbv==Nothing || rcv==Nothing) (cons (fromJust rav) (fromJust rbv) (fromJust rcv)) --- WUI combinator for tuples of arity 4. w4Tuple :: WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec (a,b,c,d) w4Tuple = wCons4JS (Just (jsTupleCons 4)) (\a b c d -> (a,b,c,d)) --- WUI combinator for constructors of arity 4. --- The first argument is the ternary constructor. --- The further arguments are the WUI specifications for the argument types. wCons4 :: (a->b->c->d->e) -> WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e wCons4 = wCons4JS Nothing wCons4JS jscons cons (WuiSpec wparama showa reada) (WuiSpec wparamb showb readb) (WuiSpec wparamc showc readc) (WuiSpec wparamd showd readd) = WuiSpec (renderTuple,tupleError, const True, Nothing) showe reade where showe wparams ve | cons va vb vc vd =:<= ve = joinSubFields wparams True [showa wparama va, showb wparamb vb, showc wparamc vc, showd wparamd vd] jscons where va,vb,vc,vd free reade wparams env s = let [ra,rb,rc,rd] = state2states s (rav,fielda) = reada wparama env ra (rbv,fieldb) = readb wparamb env rb (rcv,fieldc) = readc wparamc env rc (rdv,fieldd) = readd wparamd env rd in checkAndJoinSubFields wparams [fielda,fieldb,fieldc,fieldd] jscons (rav==Nothing || rbv==Nothing || rcv==Nothing || rdv==Nothing) (cons (fromJust rav) (fromJust rbv) (fromJust rcv) (fromJust rdv)) --- WUI combinator for tuples of arity 5. w5Tuple :: WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec (a,b,c,d,e) w5Tuple = wCons5JS (Just (jsTupleCons 5)) (\a b c d e -> (a,b,c,d,e)) --- WUI combinator for constructors of arity 5. --- The first argument is the ternary constructor. --- The further arguments are the WUI specifications for the argument types. wCons5 :: (a->b->c->d->e->f) -> WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f wCons5 = wCons5JS Nothing wCons5JS jscons cons (WuiSpec wparama showa reada) (WuiSpec wparamb showb readb) (WuiSpec wparamc showc readc) (WuiSpec wparamd showd readd) (WuiSpec wparame showe reade) = WuiSpec (renderTuple,tupleError, const True, Nothing) showf readf where showf wparams vl | cons va vb vc vd ve =:<= vl = joinSubFields wparams True [showa wparama va, showb wparamb vb, showc wparamc vc, showd wparamd vd, showe wparame ve] jscons where va,vb,vc,vd,ve free readf wparams env s = let [ra,rb,rc,rd,re] = state2states s (rav,fielda) = reada wparama env ra (rbv,fieldb) = readb wparamb env rb (rcv,fieldc) = readc wparamc env rc (rdv,fieldd) = readd wparamd env rd (rev,fielde) = reade wparame env re in checkAndJoinSubFields wparams [fielda,fieldb,fieldc,fieldd, fielde] jscons (rav==Nothing || rbv==Nothing || rcv==Nothing || rdv==Nothing || rev==Nothing) (cons (fromJust rav) (fromJust rbv) (fromJust rcv) (fromJust rdv) (fromJust rev)) --- WUI combinator for tuples of arity 6. w6Tuple :: WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec (a,b,c,d,e,f) w6Tuple = wCons6JS (Just (jsTupleCons 6)) (\a b c d e f -> (a,b,c,d,e,f)) --- WUI combinator for constructors of arity 6. --- The first argument is the ternary constructor. --- The further arguments are the WUI specifications for the argument types. wCons6 :: (a->b->c->d->e->f->g) -> WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g wCons6 = wCons6JS Nothing wCons6JS jscons cons (WuiSpec wparama showa reada) (WuiSpec wparamb showb readb) (WuiSpec wparamc showc readc) (WuiSpec wparamd showd readd) (WuiSpec wparame showe reade) (WuiSpec wparamf showf readf) = WuiSpec (renderTuple,tupleError, const True, Nothing) showg readg where showg wparams vl | cons va vb vc vd ve vf =:<= vl = joinSubFields wparams True [showa wparama va, showb wparamb vb, showc wparamc vc, showd wparamd vd, showe wparame ve, showf wparamf vf] jscons where va,vb,vc,vd,ve,vf free readg wparams env s = let [ra,rb,rc,rd,re,rf] = state2states s (rav,fielda) = reada wparama env ra (rbv,fieldb) = readb wparamb env rb (rcv,fieldc) = readc wparamc env rc (rdv,fieldd) = readd wparamd env rd (rev,fielde) = reade wparame env re (rfv,fieldf) = readf wparamf env rf in checkAndJoinSubFields wparams [fielda,fieldb,fieldc,fieldd, fielde,fieldf] jscons (rav==Nothing || rbv==Nothing || rcv==Nothing || rdv==Nothing || rev==Nothing || rfv==Nothing) (cons (fromJust rav) (fromJust rbv) (fromJust rcv) (fromJust rdv) (fromJust rev) (fromJust rfv)) --- WUI combinator for tuples of arity 7. w7Tuple :: WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec (a,b,c,d,e,f,g) w7Tuple = wCons7JS (Just (jsTupleCons 7)) (\a b c d e f g -> (a,b,c,d,e,f,g)) --- WUI combinator for constructors of arity 7. --- The first argument is the ternary constructor. --- The further arguments are the WUI specifications for the argument types. wCons7 :: (a->b->c->d->e->f->g->h) -> WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec h wCons7 = wCons7JS Nothing wCons7JS jscons cons (WuiSpec wparama showa reada) (WuiSpec wparamb showb readb) (WuiSpec wparamc showc readc) (WuiSpec wparamd showd readd) (WuiSpec wparame showe reade) (WuiSpec wparamf showf readf) (WuiSpec wparamg showg readg) = WuiSpec (renderTuple,tupleError, const True, Nothing) showh readh where showh wparams vl | cons va vb vc vd ve vf vg =:<= vl = joinSubFields wparams True [showa wparama va, showb wparamb vb, showc wparamc vc, showd wparamd vd, showe wparame ve, showf wparamf vf, showg wparamg vg] jscons where va,vb,vc,vd,ve,vf,vg free readh wparams env s = let [ra,rb,rc,rd,re,rf,rg] = state2states s (rav,fielda) = reada wparama env ra (rbv,fieldb) = readb wparamb env rb (rcv,fieldc) = readc wparamc env rc (rdv,fieldd) = readd wparamd env rd (rev,fielde) = reade wparame env re (rfv,fieldf) = readf wparamf env rf (rgv,fieldg) = readg wparamg env rg in checkAndJoinSubFields wparams [fielda,fieldb,fieldc,fieldd, fielde,fieldf,fieldg] jscons (rav==Nothing || rbv==Nothing || rcv==Nothing || rdv==Nothing || rev==Nothing || rfv==Nothing || rgv==Nothing) (cons (fromJust rav) (fromJust rbv) (fromJust rcv) (fromJust rdv) (fromJust rev) (fromJust rfv) (fromJust rgv)) --- WUI combinator for tuples of arity 8. w8Tuple :: WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec (a,b,c,d,e,f,g,h) w8Tuple = wCons8JS (Just (jsTupleCons 8)) (\a b c d e f g h -> (a,b,c,d,e,f,g,h)) --- WUI combinator for constructors of arity 8. --- The first argument is the ternary constructor. --- The further arguments are the WUI specifications for the argument types. wCons8 :: (a->b->c->d->e->f->g->h->i) -> WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i wCons8 = wCons8JS Nothing wCons8JS jscons cons (WuiSpec wparama showa reada) (WuiSpec wparamb showb readb) (WuiSpec wparamc showc readc) (WuiSpec wparamd showd readd) (WuiSpec wparame showe reade) (WuiSpec wparamf showf readf) (WuiSpec wparamg showg readg) (WuiSpec wparamh showh readh) = WuiSpec (renderTuple,tupleError, const True, Nothing) showi readi where showi wparams vl | cons va vb vc vd ve vf vg vh =:<= vl = joinSubFields wparams True [showa wparama va, showb wparamb vb, showc wparamc vc, showd wparamd vd, showe wparame ve, showf wparamf vf, showg wparamg vg, showh wparamh vh] jscons where va,vb,vc,vd,ve,vf,vg,vh free readi wparams env s = let [ra,rb,rc,rd,re,rf,rg,rh] = state2states s (rav,fielda) = reada wparama env ra (rbv,fieldb) = readb wparamb env rb (rcv,fieldc) = readc wparamc env rc (rdv,fieldd) = readd wparamd env rd (rev,fielde) = reade wparame env re (rfv,fieldf) = readf wparamf env rf (rgv,fieldg) = readg wparamg env rg (rhv,fieldh) = readh wparamh env rh in checkAndJoinSubFields wparams [fielda,fieldb,fieldc,fieldd, fielde,fieldf,fieldg,fieldh] jscons (rav==Nothing || rbv==Nothing || rcv==Nothing || rdv==Nothing || rev==Nothing || rfv==Nothing || rgv==Nothing || rhv==Nothing) (cons (fromJust rav) (fromJust rbv) (fromJust rcv) (fromJust rdv) (fromJust rev) (fromJust rfv) (fromJust rgv) (fromJust rhv)) --- WUI combinator for tuples of arity 9. w9Tuple :: WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec (a,b,c,d,e,f,g,h,i) w9Tuple = wCons9JS (Just (jsTupleCons 9)) (\a b c d e f g h i -> (a,b,c,d,e,f,g,h,i)) --- WUI combinator for constructors of arity 9. --- The first argument is the ternary constructor. --- The further arguments are the WUI specifications for the argument types. wCons9 :: (a->b->c->d->e->f->g->h->i->j) -> WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j wCons9 = wCons9JS Nothing wCons9JS jscons cons (WuiSpec wparama showa reada) (WuiSpec wparamb showb readb) (WuiSpec wparamc showc readc) (WuiSpec wparamd showd readd) (WuiSpec wparame showe reade) (WuiSpec wparamf showf readf) (WuiSpec wparamg showg readg) (WuiSpec wparamh showh readh) (WuiSpec wparami showi readi) = WuiSpec (renderTuple,tupleError, const True, Nothing) showj readj where showj wparams vl | cons va vb vc vd ve vf vg vh vi =:<= vl = joinSubFields wparams True [showa wparama va, showb wparamb vb, showc wparamc vc, showd wparamd vd, showe wparame ve, showf wparamf vf, showg wparamg vg, showh wparamh vh, showi wparami vi] jscons where va,vb,vc,vd,ve,vf,vg,vh,vi free readj wparams env s = let [ra,rb,rc,rd,re,rf,rg,rh,ri] = state2states s (rav,fielda) = reada wparama env ra (rbv,fieldb) = readb wparamb env rb (rcv,fieldc) = readc wparamc env rc (rdv,fieldd) = readd wparamd env rd (rev,fielde) = reade wparame env re (rfv,fieldf) = readf wparamf env rf (rgv,fieldg) = readg wparamg env rg (rhv,fieldh) = readh wparamh env rh (riv,fieldi) = readi wparami env ri in checkAndJoinSubFields wparams [fielda,fieldb,fieldc,fieldd, fielde,fieldf,fieldg,fieldh, fieldi] jscons (rav==Nothing || rbv==Nothing || rcv==Nothing || rdv==Nothing || rev==Nothing || rfv==Nothing || rgv==Nothing || rhv==Nothing || riv==Nothing) (cons (fromJust rav) (fromJust rbv) (fromJust rcv) (fromJust rdv) (fromJust rev) (fromJust rfv) (fromJust rgv) (fromJust rhv) (fromJust riv)) --- WUI combinator for tuples of arity 10. w10Tuple :: WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j -> WuiSpec (a,b,c,d,e,f,g,h,i,j) w10Tuple = wCons10JS (Just (jsTupleCons 10)) (\a b c d e f g h i j -> (a,b,c,d,e,f,g,h,i,j)) --- WUI combinator for constructors of arity 10. --- The first argument is the ternary constructor. --- The further arguments are the WUI specifications for the argument types. wCons10 :: (a->b->c->d->e->f->g->h->i->j->k) -> WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j -> WuiSpec k wCons10 = wCons10JS Nothing wCons10JS jscons cons (WuiSpec wparama showa reada) (WuiSpec wparamb showb readb) (WuiSpec wparamc showc readc) (WuiSpec wparamd showd readd) (WuiSpec wparame showe reade) (WuiSpec wparamf showf readf) (WuiSpec wparamg showg readg) (WuiSpec wparamh showh readh) (WuiSpec wparami showi readi) (WuiSpec wparamj showj readj) = WuiSpec (renderTuple,tupleError, const True, Nothing) showk readk where showk wparams vl | cons va vb vc vd ve vf vg vh vi vj =:<= vl = joinSubFields wparams True [showa wparama va, showb wparamb vb, showc wparamc vc, showd wparamd vd, showe wparame ve, showf wparamf vf, showg wparamg vg, showh wparamh vh, showi wparami vi, showj wparamj vj] jscons where va,vb,vc,vd,ve,vf,vg,vh,vi,vj free readk wparams env s = let [ra,rb,rc,rd,re,rf,rg,rh,ri,rj] = state2states s (rav,fielda) = reada wparama env ra (rbv,fieldb) = readb wparamb env rb (rcv,fieldc) = readc wparamc env rc (rdv,fieldd) = readd wparamd env rd (rev,fielde) = reade wparame env re (rfv,fieldf) = readf wparamf env rf (rgv,fieldg) = readg wparamg env rg (rhv,fieldh) = readh wparamh env rh (riv,fieldi) = readi wparami env ri (rjv,fieldj) = readj wparamj env rj in checkAndJoinSubFields wparams [fielda,fieldb,fieldc,fieldd, fielde,fieldf,fieldg,fieldh, fieldi,fieldj] jscons (rav==Nothing || rbv==Nothing || rcv==Nothing || rdv==Nothing || rev==Nothing || rfv==Nothing || rgv==Nothing || rhv==Nothing || riv==Nothing || rjv==Nothing) (cons (fromJust rav) (fromJust rbv) (fromJust rcv) (fromJust rdv) (fromJust rev) (fromJust rfv) (fromJust rgv) (fromJust rhv) (fromJust riv) (fromJust rjv)) --- WUI combinator for tuples of arity 11. w11Tuple :: WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j -> WuiSpec k -> WuiSpec (a,b,c,d,e,f,g,h,i,j,k) w11Tuple = wCons11JS (Just (jsTupleCons 11)) (\a b c d e f g h i j k -> (a,b,c,d,e,f,g,h,i,j,k)) --- WUI combinator for constructors of arity 11. --- The first argument is the ternary constructor. --- The further arguments are the WUI specifications for the argument types. wCons11 :: (a->b->c->d->e->f->g->h->i->j->k->l) -> WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j -> WuiSpec k -> WuiSpec l wCons11 = wCons11JS Nothing wCons11JS jscons cons (WuiSpec wparama showa reada) (WuiSpec wparamb showb readb) (WuiSpec wparamc showc readc) (WuiSpec wparamd showd readd) (WuiSpec wparame showe reade) (WuiSpec wparamf showf readf) (WuiSpec wparamg showg readg) (WuiSpec wparamh showh readh) (WuiSpec wparami showi readi) (WuiSpec wparamj showj readj) (WuiSpec wparamk showk readk) = WuiSpec (renderTuple,tupleError, const True, Nothing) showl readl where showl wparams vl | cons va vb vc vd ve vf vg vh vi vj vk =:<= vl = joinSubFields wparams True [showa wparama va, showb wparamb vb, showc wparamc vc, showd wparamd vd, showe wparame ve, showf wparamf vf, showg wparamg vg, showh wparamh vh, showi wparami vi, showj wparamj vj, showk wparamk vk] jscons where va,vb,vc,vd,ve,vf,vg,vh,vi,vj,vk free readl wparams env s = let [ra,rb,rc,rd,re,rf,rg,rh,ri,rj,rk] = state2states s (rav,fielda) = reada wparama env ra (rbv,fieldb) = readb wparamb env rb (rcv,fieldc) = readc wparamc env rc (rdv,fieldd) = readd wparamd env rd (rev,fielde) = reade wparame env re (rfv,fieldf) = readf wparamf env rf (rgv,fieldg) = readg wparamg env rg (rhv,fieldh) = readh wparamh env rh (riv,fieldi) = readi wparami env ri (rjv,fieldj) = readj wparamj env rj (rkv,fieldk) = readk wparamk env rk in checkAndJoinSubFields wparams [fielda,fieldb,fieldc,fieldd, fielde,fieldf,fieldg,fieldh, fieldi,fieldj,fieldk] jscons (rav==Nothing || rbv==Nothing || rcv==Nothing || rdv==Nothing || rev==Nothing || rfv==Nothing || rgv==Nothing || rhv==Nothing || riv==Nothing || rjv==Nothing || rkv==Nothing) (cons (fromJust rav) (fromJust rbv) (fromJust rcv) (fromJust rdv) (fromJust rev) (fromJust rfv) (fromJust rgv) (fromJust rhv) (fromJust riv) (fromJust rjv) (fromJust rkv)) --- WUI combinator for tuples of arity 12. w12Tuple :: WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j -> WuiSpec k -> WuiSpec l -> WuiSpec (a,b,c,d,e,f,g,h,i,j,k,l) w12Tuple = wCons12JS (Just (jsTupleCons 12)) (\a b c d e f g h i j k l -> (a,b,c,d,e,f,g,h,i,j,k,l)) --- WUI combinator for constructors of arity 12. --- The first argument is the ternary constructor. --- The further arguments are the WUI specifications for the argument types. wCons12 :: (a->b->c->d->e->f->g->h->i->j->k->l->m) -> WuiSpec a -> WuiSpec b -> WuiSpec c -> WuiSpec d -> WuiSpec e -> WuiSpec f -> WuiSpec g -> WuiSpec h -> WuiSpec i -> WuiSpec j -> WuiSpec k -> WuiSpec l -> WuiSpec m wCons12 = wCons12JS Nothing wCons12JS jscons cons (WuiSpec wparama showa reada) (WuiSpec wparamb showb readb) (WuiSpec wparamc showc readc) (WuiSpec wparamd showd readd) (WuiSpec wparame showe reade) (WuiSpec wparamf showf readf) (WuiSpec wparamg showg readg) (WuiSpec wparamh showh readh) (WuiSpec wparami showi readi) (WuiSpec wparamj showj readj) (WuiSpec wparamk showk readk) (WuiSpec wparaml showl readl) = WuiSpec (renderTuple,tupleError, const True, Nothing) showm readm where showm wparams vm | cons va vb vc vd ve vf vg vh vi vj vk vl =:<= vm = joinSubFields wparams True [showa wparama va, showb wparamb vb, showc wparamc vc, showd wparamd vd, showe wparame ve, showf wparamf vf, showg wparamg vg, showh wparamh vh, showi wparami vi, showj wparamj vj, showk wparamk vk, showl wparaml vl] jscons where va,vb,vc,vd,ve,vf,vg,vh,vi,vj,vk,vl free readm wparams env s = let [ra,rb,rc,rd,re,rf,rg,rh,ri,rj,rk,rl] = state2states s (rav,fielda) = reada wparama env ra (rbv,fieldb) = readb wparamb env rb (rcv,fieldc) = readc wparamc env rc (rdv,fieldd) = readd wparamd env rd (rev,fielde) = reade wparame env re (rfv,fieldf) = readf wparamf env rf (rgv,fieldg) = readg wparamg env rg (rhv,fieldh) = readh wparamh env rh (riv,fieldi) = readi wparami env ri (rjv,fieldj) = readj wparamj env rj (rkv,fieldk) = readk wparamk env rk (rlv,fieldl) = readl wparaml env rl in checkAndJoinSubFields wparams [fielda,fieldb,fieldc,fieldd, fielde,fieldf,fieldg,fieldh, fieldi,fieldj,fieldk,fieldl] jscons (rav==Nothing || rbv==Nothing || rcv==Nothing || rdv==Nothing || rev==Nothing || rfv==Nothing || rgv==Nothing || rhv==Nothing || riv==Nothing || rjv==Nothing || rkv==Nothing || rlv==Nothing) (cons (fromJust rav) (fromJust rbv) (fromJust rcv) (fromJust rdv) (fromJust rev) (fromJust rfv) (fromJust rgv) (fromJust rhv) (fromJust riv) (fromJust rjv) (fromJust rkv) (fromJust rlv)) --- WUI combinator for list structures where the list elements are vertically --- aligned in a table. wList :: WuiSpec a -> WuiSpec [a] wList (WuiSpec rendera showa reada) = WuiSpec (renderList,"Illegal list:",const True, Nothing) (\wparams vas -> joinSubFields wparams True (map (showa rendera) vas) (Just jsListComb)) (\wparams env s -> let rvs = map (reada rendera env) (state2states s) combine hide = joinSubFields wparams hide (map snd rvs) (Just jsListComb) in if Nothing `elem` (map fst rvs) then (Nothing, combine True) else let value = map (fromJust . fst) rvs in if (conditionOf wparams) value then (Just value, combine True) else (Nothing, combine False) ) where jsListComb args = JSFCall "array2list" [JSFCall "new Array" args] --- Add headings to a standard WUI for list structures: wListWithHeadings :: [String] -> WuiSpec a -> WuiSpec [a] wListWithHeadings headings wspec = wList wspec `withRendering` renderHeadings where renderHeadings hs = addHeadings (renderList hs) (map (\s->[htxt s]) headings) --- WUI combinator for list structures where the list elements are horizontally --- aligned in a table. wHList :: WuiSpec a -> WuiSpec [a] wHList wspec = wList wspec `withRendering` renderTuple --- WUI for matrices, i.e., list of list of elements --- visualized as a matrix. wMatrix :: WuiSpec a -> WuiSpec [[a]] wMatrix wspec = wList (wHList wspec) --- WUI for Maybe values. It is constructed from a WUI for --- Booleans and a WUI for the potential values. Nothing corresponds --- to a selection of False in the Boolean WUI. --- The value WUI is shown after the Boolean WUI. --- @param wspecb - a WUI specification for Boolean values --- @param wspeca - a WUI specification for the type of potential values --- @param def - a default value that is used if the current value is Nothing wMaybe :: WuiSpec Bool -> WuiSpec a -> a -> WuiSpec (Maybe a) wMaybe (WuiSpec paramb showb readb) (WuiSpec parama showa reada) def = WuiSpec (renderTuple, tupleError, const True, Nothing) (\wparams mbs -> joinSubFields wparams True [showb paramb (mbs/=Nothing), showa parama (maybe def id mbs)] Nothing) (\wparams env s -> let [rb,ra] = state2states s (rbv,fieldb) = readb paramb env rb (rav,fielda) = reada parama env ra combine hide = joinSubFields wparams hide [fieldb,fielda] Nothing in if rbv==Nothing || rav==Nothing then (Nothing, combine True) else let value = if fromJust rbv then Just (fromJust rav) else Nothing in if (conditionOf wparams) value then (Just value, combine True) else (Nothing, combine False)) --- A WUI for Maybe values where a check box is used to select Just. --- The value WUI is shown after the check box. --- @param wspec - a WUI specification for the type of potential values --- @param hexps - a list of HTML expressions shown after the check box --- @param def - a default value if the current value is Nothing wCheckMaybe :: WuiSpec a -> [HtmlExp] -> a -> WuiSpec (Maybe a) wCheckMaybe wspec exps = wMaybe (wCheckBool exps) wspec --- A WUI for Maybe values where radio buttons are used to switch --- between Nothing and Just. --- The value WUI is shown after the radio button WUI. --- @param wspec - a WUI specification for the type of potential values --- @param hexps - a list of HTML expressions shown after the Nothing button --- @param hexps - a list of HTML expressions shown after the Just button --- @param def - a default value if the current value is Nothing wRadioMaybe :: WuiSpec a -> [HtmlExp] -> [HtmlExp] -> a -> WuiSpec (Maybe a) wRadioMaybe wspec hnothing hjust = wMaybe wBool wspec where wBool = wRadioSelect (\b->if b then hjust else hnothing) [False,True] --- WUI for union types. --- Here we provide only the implementation for Either types --- since other types with more alternatives can be easily reduced to this case. wEither :: WuiSpec a -> WuiSpec b -> WuiSpec (Either a b) wEither (WuiSpec rendera showa reada) (WuiSpec renderb showb readb) = WuiSpec (head, "?", const True, Nothing) showEither readEither where showEither wparams (Left va) = let (hea,jsa,rta) = showa rendera va in altSubField wparams True hea jsa (1,rta) showEither wparams (Right vb) = let (heb,jsb,rtb) = showb renderb vb in altSubField wparams True heb jsb (2,rtb) readEither wparams env s = let (altindex,rab) = state2altstate s in case altindex of 1 -> let (rv,(he,jsck,rst)) = reada rendera env rab in checkValue (rv==Nothing) (Left (fromJust rv)) he jsck (1,rst) 2 -> let (rv,(he,jsck,rst)) = readb renderb env rab in checkValue (rv==Nothing) (Right (fromJust rv)) he jsck (2,rst) where checkValue isnothing value hexp jsck altstate = let combine hide = altSubField wparams hide hexp jsck altstate in if isnothing then (Nothing, combine True) else if (conditionOf wparams) value then (Just value, combine True) else (Nothing, combine False) --- A simple tree structure to demonstrate the construction of WUIs for tree --- types. data WTree a = WLeaf a | WNode [WTree a] --- WUI for tree types. --- The rendering specifies the rendering of inner nodes. --- Leaves are shown with their default rendering. wTree :: WuiSpec a -> WuiSpec (WTree a) wTree (WuiSpec rendera showa reada) = WuiSpec (renderList, "Illegal tree:", const True, Nothing) showTree readTree where showTree _ (WLeaf va) = let (hea,jsa,rta) = showa rendera va in altSubField rendera True hea jsa (1,rta) showTree wparams (WNode ns) = let (hes,jscks,sts) = joinSubFields wparams True (map (showTree wparams) ns) Nothing in (hes,jscks,altstate2state (2,sts)) readTree wpar env s = let (altindex,rab) = state2altstate s in case altindex of 1 -> let (rv,(he,jsck,rst)) = reada rendera env rab combine hide = altSubField rendera hide he jsck (1,rst) in checkValue combine (rv==Nothing) (WLeaf (fromJust rv)) 2 -> let rvs = map (readTree wpar env) (state2states rab) combine hide = let (hes,jscks,sts) = joinSubFields wpar hide (map snd rvs) Nothing in (hes,jscks,altstate2state (2,sts)) in checkValue combine (Nothing `elem` (map fst rvs)) (WNode (map (fromJust . fst) rvs)) where checkValue combine isnothing value = if isnothing then (Nothing, combine True) else if conditionOf wpar value then (Just value, combine True) else (Nothing, combine False) ------------------------------------------------------------------------------- -- Definition of standard rendering functions --- Standard rendering of tuples as a table with a single row. --- Thus, the elements are horizontally aligned. renderTuple :: Rendering renderTuple hexps = table [map (\h->[h]) hexps] --- Inverse operation of renderTuple. If the argument has not the --- shape of the renderTuple output, it is returned unchanged. --- In future versions, this operation is better implemented using --- functional logic features, but currently the encapsulated search --- is a bit weak for this purpose. unRenderTuple :: HtmlExp -> [HtmlExp] unRenderTuple hexp = if isTupleTable hexp then getTupleTableElems hexp else [hexp] where isTupleTable he = case he of HtmlStruct "table" [] [HtmlStruct "tr" [] tds] -> all isSingleElem tds _ -> False isSingleElem he = case he of HtmlStruct "td" _ [_] -> True _ -> False getTupleTableElems (HtmlStruct "table" [] [HtmlStruct "tr" [] tds]) = map (\ (HtmlStruct "td" _ [e]) -> e) tds -- Standard error message for tuples: tupleError = "Illegal combination:" --- Standard rendering of tuples with a tag for each element. --- Thus, each is preceded by a tag, that is set in bold, and all --- elements are vertically aligned. renderTaggedTuple :: [String] -> Rendering renderTaggedTuple tags hexps = table (map (\(t,h)->[[bold [htxt t]],[h]]) (zip tags hexps)) --- Standard rendering of lists as a table with a row for each item: --- Thus, the elements are vertically aligned. renderList :: Rendering renderList hexps = mergeTableOfTable (table (map (\h->[[h]]) hexps)) `addAttr` ("border","1") mergeTableOfTable :: HtmlExp -> HtmlExp mergeTableOfTable (HtmlStruct "table" attrs rows) = HtmlStruct "table" attrs (if all isRowWithSingleTableData rows then map mergeRowWithSingleTableData rows else rows ) isRowWithSingleTableData row = case row of (HtmlStruct "tr" [] [HtmlStruct "td" [] [HtmlStruct "table" _ [HtmlStruct "tr" _ _]]]) -> True _ -> False mergeRowWithSingleTableData (HtmlStruct "tr" [] [HtmlStruct "td" [] [HtmlStruct "table" _ [row]]]) = row ------------------------------------------------------------------------------- -- Main operations to generate HTML structures and handlers from -- WUI specifications: --- Generates an HTML form from a WUI data specification, --- an initial value and an update form. mainWUI :: WuiSpec a -> a -> (a -> IO HtmlForm) -> IO HtmlForm mainWUI wuispec val store = do let (hexp,whandler) = wui2html wuispec val store return $ form "WUI" [hexp, breakline, wuiHandler2button "Submit" whandler] --- Generates HTML editors and a handler from a WUI data specification, --- an initial value and an update form. wui2html :: WuiSpec a -> a -> (a -> IO HtmlForm) -> (HtmlExp,WuiHandler) wui2html wspec val store = wuiWithErrorForm wspec val store standardErrorForm --- A standard error form for WUIs. standardErrorForm :: HtmlExp -> WuiHandler -> IO HtmlForm standardErrorForm hexp whandler = return $ standardForm "Input error" [hexp, wuiHandler2button "Submit" whandler] --- Puts a WUI into a HTML form containing "holes" for the WUI and the --- handler. wuiInForm :: WuiSpec a -> a -> (a -> IO HtmlForm) -> (HtmlExp -> WuiHandler -> IO HtmlForm) -> IO HtmlForm wuiInForm wspec val store userform = answerForm (wuiWithErrorForm wspec val store userform) where answerForm (hexp,whandler) = userform hexp whandler --- Generates HTML editors and a handler from a WUI data specification, --- an initial value and an update form. In addition to wui2html, --- we can provide a skeleton form used to show illegal inputs. wuiWithErrorForm :: WuiSpec a -> a -> (a -> IO HtmlForm) -> (HtmlExp -> WuiHandler -> IO HtmlForm) -> (HtmlExp,WuiHandler) wuiWithErrorForm wspec val store errorform = showAndReadWUI wspec store errorform (generateWUI wspec val) generateWUI :: WuiSpec a -> a -> (HtmlExp,Maybe JSExp, CgiEnv -> (Maybe a,HtmlState)) generateWUI (WuiSpec wparams showhtml readval) val = hst2result (showhtml wparams val) where hst2result (htmledits,jsfs,wstate) = (htmledits, jsfs, \env -> readval wparams env wstate) showAndReadWUI :: WuiSpec a -> (a -> IO HtmlForm) -> (HtmlExp -> WuiHandler -> IO HtmlForm) -> (HtmlExp,Maybe JSExp,CgiEnv->(Maybe a,HtmlState)) -> (HtmlExp,WuiHandler) showAndReadWUI wspec store errorform (htmledits,jsfs,readenv) = (inline [wuiStyleSheet, htmledits], WHandler (htmlhandler wspec) jsfs) where htmlhandler wui@(WuiSpec wparams _ readval) env = let (mbnewval, (htmlerrform,htmlerrjsfs,errwstate)) = readenv env in maybe (let (errhexp,errwhdl) = showAndReadWUI wui store errorform (htmlerrform,htmlerrjsfs, \errenv -> readval wparams errenv errwstate) in errorform errhexp errwhdl) (\newval -> seq (normalForm newval) -- to strip off unused lvars (store newval)) mbnewval -------------------------------------------------------------------------- -- The style sheet used in WUIs: wuiStyleSheet = styleSheet $ "\n.wuihide { display: none; }\n" ++ ".wuinohide { display: inline; color: red; font-weight: bold ; background-color: yellow; }\n" ++ ".wuipassiveerrmsg { padding: 0px; border-spacing: 0px; }\n"++ ".wuiactiveerrmsg { padding: 0px; border-spacing: 0px; background-color: yellow; border-width: 2px; border-style: solid; border-color: red; }\n" -------------------------------------------------------------------------- curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/XML.curry000066400000000000000000000360601305333611600227630ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for processing XML data. --- --- Warning: the structure of this library is not stable and --- might be changed in the future! --- --- @author Michael Hanus --- @version January 2011 --- @category web ------------------------------------------------------------------------------ module XML(XmlExp(..),Encoding(..),XmlDocParams(..), tagOf,elemsOf,textOf,textOfXml,xtxt,xml, showXmlDoc,showXmlDocWithParams, writeXmlFile,writeXmlFileWithParams,parseXmlString,readXmlFile, readUnsafeXmlFile,readFileWithXmlDocs,updateXmlFile) where import Char import Read import List(intersperse) ------------------------------------------------------------------------------ --- The data type for representing XML expressions. --- @cons XText - a text string (PCDATA) --- @cons XElem - an XML element with tag field, attributes, and a list --- of XML elements as contents data XmlExp = XText String -- text string (PCDATA) | XElem String [(String,String)] [XmlExp] -- (tag attrs contents) ------------------------------------------------------------------------------ --- The data type for encodings used in the XML document. data Encoding = StandardEnc | Iso88591Enc -- Transform an encoding into its XML-attribute form encoding2Attribute :: Encoding -> String encoding2Attribute StandardEnc = "" encoding2Attribute Iso88591Enc = "encoding=\"iso-8859-1\" " -- Transform an encoding into its encoding-function encoding2EncFunc :: Encoding -> String -> String encoding2EncFunc StandardEnc = standardEncoding encoding2EncFunc Iso88591Enc = iso88591Encoding ------------------------------------------------------------------------------ -- List of encoding maps ------------------------------------------------------------------------------ -- standard encoding map standardEncoding :: String -> String standardEncoding [] = [] standardEncoding (c:cs) | c=='<' = "<" ++ standardEncoding cs | c=='>' = ">" ++ standardEncoding cs | c=='&' = "&" ++ standardEncoding cs | c=='"' = """ ++ standardEncoding cs | c=='\'' = "'" ++ standardEncoding cs | ord c < 32 = "&#" ++ show (ord c) ++ ";" ++ standardEncoding cs | ord c > 127 = "&#" ++ show (ord c) ++ ";" ++ standardEncoding cs | otherwise = c : standardEncoding cs -- iso-8859-1 iso88591Encoding :: String -> String iso88591Encoding [] = [] iso88591Encoding (c:cs) = if ord c `elem` iso88591list then c : iso88591Encoding cs else standardEncoding [c] ++ iso88591Encoding cs -- iso-8859-1-list -- not yet completed... iso88591list = [192,193,194,195,196,197,198,199,200,201,202,203,204,205,207, 208,209,210,211,212,214,216,217,218,219,220,221,224,225,228, 229,226,227,230,231,233,232,235,234,236,237,239,240,241,248, 246,242,243,244,245,250,249,252,251,253,255] ------------------------------------------------------------------------------ --- The data type for XML document parameters. --- @cons Enc - the encoding for a document --- @cons DtdUrl - the url of the DTD for a document data XmlDocParams = Enc Encoding | DtdUrl String -- get the right encoding (i.e., first or standard encoding if not present) -- from a list of XmlDocParams lookupEncoding :: [XmlDocParams] -> Encoding lookupEncoding (Enc f:_) = f lookupEncoding (DtdUrl _:l) = lookupEncoding l lookupEncoding [] = StandardEnc -- get the first DtdUrl from a list of XmlDocParams lookupDtdUrl :: [XmlDocParams] -> String lookupDtdUrl (Enc _:l) = lookupDtdUrl l lookupDtdUrl (DtdUrl url:_) = url -- does a XmlDocParam include a DtdUrl? hasDtdUrl :: [XmlDocParams] -> Bool hasDtdUrl [] = False hasDtdUrl (DtdUrl _:_) = True hasDtdUrl (Enc _:l) = hasDtdUrl l ------------------------------------------------------------------------------ -- useful selectors: --- Returns the tag of an XML element (or empty for a textual element). tagOf :: XmlExp -> String tagOf (XElem tag _ _) = tag tagOf (XText _) = "" --- Returns the child elements an XML element. elemsOf :: XmlExp -> [XmlExp] elemsOf (XElem _ _ xexps) = xexps elemsOf (XText _) = [] --- Extracts the textual contents of a list of XML expressions. --- Useful auxiliary function when transforming XML expressions into --- other data structures. --- --- For instance, --- textOf [XText "xy", XElem "a" [] [], XText "bc"] == "xy bc" textOf :: [XmlExp] -> String textOf = unwords . filter (not . null) . map textOfXmlExp where textOfXmlExp (XText s) = s textOfXmlExp (XElem _ _ xs) = textOf xs --- Included for backward compatibility, better use textOf! textOfXml :: [XmlExp] -> String textOfXml = textOf ------------------------------------------------------------------------------ -- some useful abbreviations: --- Basic text (maybe containing special XML chars). xtxt :: String -> XmlExp xtxt s = XText s --- XML element without attributes. xml :: String -> [XmlExp] -> XmlExp xml t c = XElem t [] c ------------------------------------------------------------------------------ -- Pretty printer for XML documents ------------------------------------------------------------------------------ --- Writes a file with a given XML document. writeXmlFile :: String -> XmlExp -> IO () writeXmlFile file xexp = writeXmlFileWithParams file [Enc StandardEnc] xexp --- Writes a file with a given XML document and XML parameters. writeXmlFileWithParams :: String -> [XmlDocParams] -> XmlExp -> IO () writeXmlFileWithParams file ps xexp = writeFile file (showXmlDocWithParams ps xexp) ------------------------------------------------------------------------------ --- Show an XML document in indented format as a string. ------------------------------------------------------------------------------ showXmlDoc :: XmlExp -> String showXmlDoc xexp = showXmlDocWithParams [] xexp showXmlDocWithParams :: [XmlDocParams] -> XmlExp -> String showXmlDocWithParams ps (XElem root attrL xmlEL) = "\n\n" ++ (if hasDtdUrl ps then "\n\n" else "") ++ showXmlExp 0 (encoding2EncFunc (lookupEncoding ps)) (XElem root attrL xmlEL) showXmlExp :: Int -> (String -> String) -> XmlExp -> String showXmlExp i encFun (XText s) = xtab i ++ (encFun s) ++ "\n" showXmlExp i encFun (XElem tag attrs xexps) = xtab i ++ showXmlOpenTag tag attrs encFun ++ if null xexps then " />\n" else if length xexps == 1 && isXText (head xexps) then let [XText s] = xexps in ">" ++ (encFun s) ++ "\n" else ">\n" ++ showXmlExps (i+2) xexps encFun ++ xtab i ++ "\n" xtab n = take n (repeat ' ') showXmlOpenTag tag attrs encFun = "<" ++ tag ++ concat (map ((" "++) . attr2string) attrs) where attr2string (attr,value) = attr ++ "=\"" ++ (encFun value) ++ "\"" showXmlExps :: Int -> [XmlExp] -> (String -> String) -> String showXmlExps encFun xexps i = concatMap (showXmlExp encFun i) xexps isXText :: XmlExp -> Bool isXText (XText _) = True isXText (XElem _ _ _) = False -- unquote special characters (<,>,&,',") in an XML string: xmlUnquoteSpecials :: String -> String xmlUnquoteSpecials [] = [] xmlUnquoteSpecials (c:cs) | c=='&' = let (special,rest) = splitAtChar ';' cs in xmlUnquoteSpecial special rest | otherwise = c : xmlUnquoteSpecials cs xmlUnquoteSpecial special cs | special=="lt" = '<' : xmlUnquoteSpecials cs | special=="gt" = '>' : xmlUnquoteSpecials cs | special=="amp" = '&' : xmlUnquoteSpecials cs | special=="quot" = '"' : xmlUnquoteSpecials cs | special=="apos" = '\'' : xmlUnquoteSpecials cs | special=="auml" = '\228' : xmlUnquoteSpecials cs | special=="ouml" = '\246' : xmlUnquoteSpecials cs | special=="uuml" = '\252' : xmlUnquoteSpecials cs | special=="Auml" = '\196' : xmlUnquoteSpecials cs | special=="Ouml" = '\214' : xmlUnquoteSpecials cs | special=="Uuml" = '\220' : xmlUnquoteSpecials cs | special=="szlig"= '\223' : xmlUnquoteSpecials cs | otherwise = unquoteUnicode special ++ xmlUnquoteSpecials cs unquoteUnicode :: String -> String unquoteUnicode [] = [] unquoteUnicode (c:cs) | c=='#' = case cs of 'x':cs' -> [chr (readHex cs')] _ -> [chr (readInt cs)] | otherwise = '&':(c:cs) ++ ";" ------------------------------------------------------------------------------ -- Parser for XML documents ------------------------------------------------------------------------------ --- Reads a file with an XML document and returns --- the corresponding XML expression. readXmlFile :: String -> IO XmlExp readXmlFile file = do xmlstring <- readFile file let xexps = parseXmlString xmlstring if null xexps then error ("File "++file++" contains no XML document!") else if null (tail xexps) then return (head xexps) else error ("File "++file++" contains more than one XML document!") --- Tries to read a file with an XML document and returns --- the corresponding XML expression, if possible. --- If file or parse errors occur, Nothing is returned. readUnsafeXmlFile :: String -> IO (Maybe XmlExp) readUnsafeXmlFile file = catch (readXmlFile file >>= return . Just) (\_ -> return Nothing) --- Pretty prints the contents of an XML file. showXmlFile :: String -> IO () showXmlFile file = readXmlFile file >>= putStr . showXmlDoc --- Reads a file with an arbitrary sequence of XML documents and --- returns the list of corresponding XML expressions. readFileWithXmlDocs :: String -> IO [XmlExp] readFileWithXmlDocs file = readFile file >>= return . parseXmlString ------------------------------------------------------------------------------ --- Transforms an XML string into a list of XML expressions. --- If the XML string is a well structured document, the list --- of XML expressions should contain exactly one element. parseXmlString :: String -> [XmlExp] parseXmlString s = fst (parseXmlTokens (scanXmlString s) Nothing) -- parse a list of XML tokens into list of XML expressions: -- parseXmlTokens tokens stoptoken = (xml_expressions, remaining_tokens) parseXmlTokens :: [XmlExp] -> Maybe String -> ([XmlExp],[XmlExp]) parseXmlTokens [] Nothing = ([],[]) parseXmlTokens (XText s : xtokens) stop = let (xexps, rem_xtokens) = parseXmlTokens xtokens stop in (XText (xmlUnquoteSpecials s) : xexps, rem_xtokens) parseXmlTokens (XElem (t:ts) args cont : xtokens) stop | t == '<' && head ts /= '/' = let (xexps1, xtokens1) = parseXmlTokens xtokens (Just ts) (xexps, rem_xtokens) = parseXmlTokens xtokens1 stop in (XElem ts args xexps1 : xexps, rem_xtokens) | t == '<' && head ts == '/' = if maybe False (==(tail ts)) stop then ([], xtokens) -- stop this parser if appropriate stop token reached else let (xexps, rem_xtokens) = parseXmlTokens xtokens stop in (XElem ts args cont : xexps, rem_xtokens) | otherwise = let (xexps, rem_xtokens) = parseXmlTokens xtokens stop in (XElem (t:ts) args cont : xexps, rem_xtokens) -- scan an XML string into list of XML tokens: -- here we reuse XML expressions for representing XML tokens: -- single open or closing tags are returned by the scanner -- as an XElem with no contents and first character '<' added to the tag field scanXmlString :: String -> [XmlExp] scanXmlString s = scanXml (dropBlanks s) where scanXml [] = [] scanXml (c:cs) = if c=='<' then scanXmlElem cs else let (initxt,remtag) = scanXmlText (c:cs) in XText initxt : scanXml remtag -- scan an XML text until next tag and remove superflous blanks: scanXmlText :: String -> (String,String) --original definition: --scanXmlText s = let (s1,s2) = break (=='<') s -- in (concat (intersperse " " (words s1)), s2) --this implementation is more efficient: scanXmlText [] = ([],[]) scanXmlText (c:cs) | c=='<' = ([],c:cs) | isSpace c = let (txt,rem) = scanXmlText (dropBlanks cs) in (if null txt then txt else ' ':txt, rem) | otherwise = let (txt,rem) = scanXmlText cs in (c:txt,rem) -- scan an XML element: scanXmlElem :: String -> [XmlExp] scanXmlElem [] = [] scanXmlElem (c:cs) | c=='!' = if take 2 cs == "--" then scanXmlComment (drop 2 cs) else scanXmlCData cs | c=='?' = scanXmlProcInstr cs | otherwise = scanXmlElemName [c] cs scanXmlElemName ct [] = [XElem ('<':ct) [] []] scanXmlElemName ct (c:cs) | c=='>' = XElem ('<':ct) [] [] : scanXmlString cs | isSpace c = let (attrs,rest) = parseAttrs (dropBlanks cs) in if (head rest)=='/' then XElem ct attrs [] : scanXmlString (drop 2 rest) else XElem ('<':ct) attrs [] : scanXmlString (tail rest) | c=='/' && head cs == '>' = XElem ct [] [] : scanXmlString (tail cs) | otherwise = scanXmlElemName (ct++[c]) cs -- scan (and drop) an XML comment: scanXmlComment :: String -> [XmlExp] scanXmlComment [] = [] scanXmlComment (c:cs) = if c=='-' && take 2 cs == "->" then scanXmlString (drop 2 cs) else scanXmlComment cs -- scan (and drop) an XML CDATA element (simplified version): scanXmlCData :: String -> [XmlExp] scanXmlCData cs = let rest = dropCData cs in if head rest == '>' then scanXmlString (tail rest) else scanXmlCData rest dropCData [] = [] dropCData (c:cs) | c=='[' = tail (dropWhile (/=']') cs) -- must be improved | c=='>' = c:cs | otherwise = dropCData cs -- scan (and drop) an XML processing instructions: scanXmlProcInstr :: String -> [XmlExp] scanXmlProcInstr [] = [] scanXmlProcInstr (c:cs) = if c=='?' && head cs == '>' then scanXmlString (tail cs) else scanXmlProcInstr cs -- parse a string as an attribute list: parseAttrs :: String -> ([(String,String)],String) parseAttrs [] = ([],[]) parseAttrs (c:cs) | isAlpha c = let (name,rest1) = splitAtChar '=' (c:cs) (value,rest2) = splitAtChar '"' (tail rest1) (rem_attrs,rem_inp) = parseAttrs (dropBlanks rest2) in ((name,xmlUnquoteSpecials value):rem_attrs, rem_inp) | otherwise = ([],c:cs) -- drop blanks in input string: dropBlanks = dropWhile isSpace -- split string at particular character, if possible: splitAtChar _ [] = ([],[]) splitAtChar char (c:cs) = if c==char then ([],cs) else let (first,rest) = splitAtChar char cs in (c:first,rest) ------------------------------------------------------------------------------ --- An action that updates the contents of an XML file by some transformation --- on the XML document. --- @param f - the function to transform the XML document in the file --- @param file - the name of the XML file updateXmlFile :: (XmlExp -> XmlExp) -> String -> IO () updateXmlFile xmltrans filename = do xdoc <- readXmlFile filename writeXmlFile filename $!! (xmltrans xdoc) -- end of XML library curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/XmlConv.curry000066400000000000000000000731511305333611600237130ustar00rootroot00000000000000--- Provides type-based combinators to construct XML converters. --- Arbitrary XML data can be represented as algebraic datatypes and vice versa. --- See --- here for a description of this library. --- --- @author Sebastian Fischer (with changes by Michael Hanus) --- @version February 2015 --- @category web module XmlConv ( -- converter types XElemConv, XAttrConv, XPrimConv, XOptConv, XRepConv, -- Reads and Shows types for XML trees XmlReads, XmlShows, -- read and show functions xmlRead, xmlShow, xmlReads, xmlShows, -- converter for primitive values int, float, char, string, -- combinators for complex XML data (!), element, empty, attr, adapt, opt, rep, -- attribute converter for primitive values and booleans aInt, aFloat, aChar, aString, aBool, -- element converter eInt, eFloat, eChar, eString, eBool, eEmpty, eOpt, eRep, -- converter for sequences seq1, seq2, seq3, seq4, seq5, seq6, -- converter for repeated sequences repSeq1, repSeq2, repSeq3, repSeq4, repSeq5, repSeq6, -- element converter for sequences eSeq1, eSeq2, eSeq3, eSeq4, eSeq5, eSeq6, -- element converter for repeated sequences eRepSeq1, eRepSeq2, eRepSeq3, eRepSeq4, eRepSeq5, eRepSeq6 ) where import XML import Read ( readInt ) import ReadShowTerm ( readQTerm ) infixr 0 ! infixl 1 />= --- Phantom type for XML data that may be part of a repetition data Repeatable = Repeatable --- Phantom type for XML data that must not be part of a repetition data NotRepeatable = NotRepeatable --- Phantom type for single elements data Elem = Elem --- Phantom type for primitive values, multiple elements and/or attributes data NoElem = NoElem type Attrs = [(String,String)] type Childs = (Attrs,[XmlExp]) --- Type of functions that consume some XML data to compute a result type XmlReads a = Childs -> (a,Childs) --- Type of functions that extend XML data corresponding to a given value type XmlShows a = a -> Childs -> Childs data XmlConv _ _ a = Conv (XmlReads a) (XmlShows a) type ValConv a = (String -> a,a -> String) --- Type of converters for XML elements type XElemConv a = XmlConv Repeatable Elem a --- Type of converters for attributes type XAttrConv a = XmlConv NotRepeatable NoElem a --- Type of converters for primitive values type XPrimConv a = XmlConv NotRepeatable NoElem a --- Type of converters for optional values type XOptConv a = XmlConv NotRepeatable NoElem a --- Type of converters for repetitions type XRepConv a = XmlConv NotRepeatable NoElem a --- Type of converters for sequences type XSeqConv a = XmlConv NotRepeatable NoElem a -- Monadic bind for XML parser (/>=) :: XmlReads a -> (a -> XmlReads b) -> XmlReads b rd />= f = \childs -> case rd childs of (a,childs') -> f a childs' -- Monadic return for XML parser ret :: a -> XmlReads a ret x y = (x,y) --- Takes an XML converter and returns a function that consumes XML data --- and returns the remaining data along with the result. --- --- @param conv XML converter --- @return XmlReads function xmlReads :: XmlConv _ _ a -> XmlReads a xmlReads (Conv rd _) = rd --- Takes an XML converter and returns a function that extends XML data --- with the representation of a given value. --- --- @param conv XML converter --- @return XmlShows function xmlShows :: XmlConv _ _ a -> XmlShows a xmlShows (Conv _ sh) = sh --- Takes an XML converter and an XML expression and returns a --- corresponding Curry value. --- --- @param conv XML converter --- @return XML read function xmlRead :: XmlConv _ Elem a -> XmlExp -> a xmlRead xa x = a where (a,([],[])) = xmlReads xa ([],[x]) --- Takes an XML converter and a value and returns a corresponding --- XML expression. --- --- @param conv XML converter --- @return XML show function xmlShow :: XmlConv _ Elem a -> a -> XmlExp xmlShow xa a = x where ([],[x]) = xmlShows xa a ([],[]) int_ :: ValConv Int int_ = (readInt,show) float_ :: ValConv Float float_ = (readQTerm,show) char_ :: ValConv Char char_ = (head,(:[])) string_ :: ValConv String string_ = (id,id) bool_ :: String -> String -> ValConv Bool bool_ true false = (readBool,showBool) where fromJust (Just x) = x readBool s = fromJust (lookup s [(true,True),(false,False)]) showBool b = if b then true else false val_ :: ValConv a -> XPrimConv a val_ (rda,sha) = Conv rd sh where rd childs = (rda a,(attrs,elems)) where (attrs,XText a : elems) = childs sh a childs = (attrs,XText (sha a) : elems) where (attrs,elems) = childs --- Creates an XML converter for integer values. Integer values must not be --- used in repetitions and do not represent XML elements. --- --- @return Int converter int :: XPrimConv Int int = val_ int_ --- Creates an XML converter for float values. Float values must not be --- used in repetitions and do not represent XML elements. --- --- @return Float converter float :: XPrimConv Float float = val_ float_ --- Creates an XML converter for character values. Character values must not be --- used in repetitions and do not represent XML elements. --- --- @return Char converter char :: XPrimConv Char char = val_ char_ --- Creates an XML converter for string values. String values must not be --- used in repetitions and do not represent XML elements. --- --- @return String converter string :: XPrimConv String string = Conv rd sh where rd childs = ("",childs) ? case elems of XText s : elems' -> (s,(attrs,elems')) where (attrs,elems) = childs sh "" childs = childs sh s@(_:_) childs = (attrs,XText s : elems) where (attrs,elems) = childs --- Parallel composition of XML converters. --- --- @return Nondeterministic choice of XML converters (!) :: XmlConv rep elem a -> XmlConv rep elem a -> XmlConv rep elem a (Conv rd1 sh1) ! (Conv rd2 sh2) = Conv rd sh where rd childs = rd1 childs ? rd2 childs sh x = sh1 x ? sh2 x --- Takes an arbitrary XML converter and returns a converter representing --- an XML element that contains the corresponding data. XML elements may be --- used in repetitions. --- --- @param name Tag name of the XML element --- @param conv XML converter for the childs of the XML element --- @return XML converter representing an XML element element :: String -> XmlConv _ _ a -> XElemConv a element name xa = Conv rd sh where rd childs | myName==name = case xmlReads xa (myAttrs,myElems) of (a,([],[])) -> (a,(attrs,elems)) where (attrs,XElem myName myAttrs myElems : elems) = childs sh a childs = case xmlShows xa a ([],[]) of (myAttrs,myElems) -> (attrs,XElem name myAttrs myElems : elems) where (attrs,elems) = childs --- Takes a value and returns an XML converter for this value which is not --- represented as XML data. Empty XML data must not be used in repetitions --- and does not represent an XML element. --- --- @param val Value without an XML representation --- @return Empty XML converter empty :: a -> XPrimConv a empty val = Conv rd sh where rd = ret val sh v childs | v=:=val = childs --- Takes a name and string conversion functions and returns an XML converter --- that represents an attribute. Attributes must not be used in repetitions --- and do not represent an XML element. --- --- @param name Attribute name --- @param readShow functions that convert between values and strings --- @return Attribute converter attr :: String -> ValConv a -> XAttrConv a attr name (rda,sha) = Conv rd sh where rd childs = (rda value,(attrs',elems)) where (attrs,elems) = childs ((_,value),attrs') = exposeBy ((name==) . fst) attrs sh a childs = ((name,sha a) : attrs,elems) where (attrs,elems) = childs -- Fetch a list element that satisfies a given predicate. exposeBy :: (a -> Bool) -> [a] -> (a,[a]) exposeBy p (x:xs) = if p x then (x,xs) else (y,x:ys) where (y,ys) = exposeBy p xs --- Converts between arbitrary XML converters for different types. --- --- @param a2b_b2a functions that convert between values of types a and b --- @param conv XML converter for type a --- @return XML converter for type b adapt :: (a -> b,b -> a) -> XmlConv rep e a -> XmlConv rep e b adapt (a2b,b2a) (Conv rda sha) = Conv rd sh where rd = rda />= ret . a2b sh = sha . b2a --- Creates a converter for arbitrary optional XML data. Optional XML data --- must not be used in repetitions and does not represent an XML element. --- --- @param conv XML converter --- @return XML converter for optional data represented by the given converter opt :: XmlConv _ _ a -> XOptConv (Maybe a) opt xa = Conv rd sh where rd childs = ret Nothing childs ? (xmlReads xa />= ret . Just) childs sh Nothing = id sh (Just a) = xmlShows xa a --- Takes an XML converter representing repeatable data and returns an --- XML converter that represents repetitions of this data. Repetitions --- must not be used in other repetitions and do not represent XML elements. --- --- @param conv XML converter representing repeatable data --- @return XML converter representing repetitions rep :: XmlConv Repeatable _ a -> XRepConv [a] rep xa = Conv rd sh where rd childs = ret [] childs ? ( xmlReads xa />= \x -> rd />= \xs -> ret (x:xs)) childs sh = foldr (.) id . map (xmlShows xa) --- Creates an XML converter for integer attributes. Integer attributes --- must not be used in repetitions and do not represent XML elements. --- --- @param name Attribute name --- @return Int attribute converter aInt :: String -> XAttrConv Int aInt name = attr name int_ --- Creates an XML converter for float attributes. Float attributes --- must not be used in repetitions and do not represent XML elements. --- --- @param name Attribute name --- @return Float attribute converter aFloat :: String -> XAttrConv Float aFloat name = attr name float_ --- Creates an XML converter for character attributes. Character attributes --- must not be used in repetitions and do not represent XML elements. --- --- @param name Attribute name --- @return Char attribute converter aChar :: String -> XAttrConv Char aChar name = attr name char_ --- Creates an XML converter for string attributes. String attributes --- must not be used in repetitions and do not represent XML elements. --- --- @param name Attribute name --- @return String attribute converter aString :: String -> XAttrConv String aString name = attr name string_ --- Creates an XML converter for boolean attributes. Boolean attributes --- must not be used in repetitions and do not represent XML elements. --- --- @param name Attribute name --- @param true String representing True --- @param false String representing False --- @return Bool attribute converter aBool :: String -> String -> String -> XAttrConv Bool aBool name true false = attr name (bool_ true false) --- Creates an XML converter for integer elements. Integer elements may be --- used in repetitions. --- --- @param name Tag name of the XML element containing the integer value --- @return Int element converter eInt :: String -> XElemConv Int eInt name = element name int --- Creates an XML converter for float elements. Float elements may be --- used in repetitions. --- --- @param name Tag name of the XML element containing the float value --- @return Float element converter eFloat :: String -> XElemConv Float eFloat name = element name float --- Creates an XML converter for character elements. Character elements may be --- used in repetitions. --- --- @param name Tag name of the XML element containing the character value --- @return Char element converter eChar :: String -> XElemConv Char eChar name = element name char --- Creates an XML converter for string elements. String elements may be --- used in repetitions. --- --- @param name Tag name of the XML element containing the string value --- @return String element converter eString :: String -> XElemConv String eString name = element name string --- Creates an XML converter for boolean elements. Boolean elements may be --- used in repetitions. --- --- @param true Tag name of the XML element representing True --- @param false Tag name of the XML element representing False --- @return Bool element converter eBool :: String -> String -> XElemConv Bool eBool true false = eEmpty true True ! eEmpty false False --- Takes a name and a value and creates an empty XML element that represents --- the given value. The created element may be used in repetitions. --- --- @param name Tag name of the empty element --- @param val Value represented by the empty element --- @return XML converter representing an empty XML element eEmpty :: String -> a -> XElemConv a eEmpty name a = element name (empty a) --- Creates an XML converter that represents an element containing --- optional XML data. The created element may be used in repetitions. --- --- @param name Tag name of the element containing optional XML data --- @return XML converter for an element enclosing optional XML data eOpt :: String -> XmlConv _ _ a -> XElemConv (Maybe a) eOpt name xa = element name (opt xa) --- Creates an XML converter that represents an element containing --- repeated XML data. The created element may be used in repetitions. --- --- @param name Tag name of the element containing repeated XML data --- @return XML converter for an element enclosing repeated XML data eRep :: String -> XmlConv Repeatable _ a -> XElemConv [a] eRep name xa = element name (rep xa) --- Creates an XML converter representing a sequence of arbitrary XML data. --- The sequence must not be used in repetitions and does not represent an --- XML element. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a sequence seq1 :: (a -> b) -> XmlConv rep _ a -> XmlConv rep NoElem b seq1 cons xa = Conv rd sh where rd = xmlReads xa />= ret . cons sh arg | cons a =:<= arg = xmlShows xa a where a free --- Creates an XML converter that represents a repetition of a sequence --- of repeatable XML data. The repetition may be used in other --- repetitions but does not represent an XML element. This combinator is --- provided because converters for repeatable sequences cannot be --- constructed by the seq combinators. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a repetition of a sequence repSeq1 :: (a -> b) -> XmlConv Repeatable _ a -> XRepConv [b] repSeq1 cons xa = rep (seq1 cons xa) --- Creates an XML converter for compound values represented as an --- XML element with children that correspond to the values components. --- The element can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the compound value --- @param conv(s) XML converter for the components --- @return XML element converter for a compound value eSeq1 :: String -> (a -> b) -> XmlConv _ _ a -> XElemConv b eSeq1 name cons xa = element name (seq1 cons xa) --- Creates an XML converter for repetitions of sequences represented as an --- XML element that can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the sequence --- @param conv(s) XML converter for the components --- @return XML element converter for a repeated sequence eRepSeq1 :: String -> (a -> b) -> XmlConv Repeatable _ a -> XElemConv [b] eRepSeq1 name cons xa = element name (repSeq1 cons xa) seq2_ :: (a -> b -> c) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ NoElem c seq2_ cons xa xb = Conv rd sh where rd = xmlReads xa />= \a -> xmlReads xb />= \b -> ret (cons a b) sh arg | cons a b =:<= arg = xmlShows xa a . xmlShows xb b where a,b free --- Creates an XML converter representing a sequence of arbitrary XML data. --- The sequence must not be used in repetitions and does not represent an --- XML element. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a sequence seq2 :: (a -> b -> c) -> XmlConv _ _ a -> XmlConv _ _ b -> XSeqConv c seq2 = seq2_ --- Creates an XML converter that represents a repetition of a sequence --- of repeatable XML data. The repetition may be used in other --- repetitions and does not represent an XML element. This combinator is --- provided because converters for repeatable sequences cannot be --- constructed by the seq combinators. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a repetition of a sequence repSeq2 :: (a -> b -> c) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XRepConv [c] repSeq2 cons xa xb = rep (seq2_ cons xa xb) --- Creates an XML converter for compound values represented as an --- XML element with children that correspond to the values components. --- The element can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the compound value --- @param conv(s) XML converter for the components --- @return XML element converter for a compound value eSeq2 :: String -> (a -> b -> c) -> XmlConv _ _ a -> XmlConv _ _ b -> XElemConv c eSeq2 name cons xa xb = element name (seq2 cons xa xb) --- Creates an XML converter for repetitions of sequences represented as an --- XML element that can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the sequence --- @param conv(s) XML converter for the components --- @return XML element converter for a repeated sequence eRepSeq2 :: String -> (a -> b -> c) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XElemConv [c] eRepSeq2 name cons xa xb = element name (repSeq2 cons xa xb) seq3_ :: (a -> b -> c -> d) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ NoElem d seq3_ cons xa xb xc = Conv rd sh where rd = xmlReads xa />= \a -> xmlReads xb />= \b -> xmlReads xc />= \c -> ret (cons a b c) sh arg | (cons a b c) =:<= arg = xmlShows xa a . xmlShows xb b . xmlShows xc c where a,b,c free --- Creates an XML converter representing a sequence of arbitrary XML data. --- The sequence must not be used in repetitions and does not represent an --- XML element. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a sequence seq3 :: (a -> b -> c -> d) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XSeqConv d seq3 = seq3_ --- Creates an XML converter that represents a repetition of a sequence --- of repeatable XML data. The repetition may be used in other --- repetitions and does not represent an XML element. This combinator is --- provided because converters for repeatable sequences cannot be --- constructed by the seq combinators. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a repetition of a sequence repSeq3 :: (a -> b -> c -> d) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XRepConv [d] repSeq3 cons xa xb xc = rep (seq3_ cons xa xb xc) --- Creates an XML converter for compound values represented as an --- XML element with children that correspond to the values components. --- The element can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the compound value --- @param conv(s) XML converter for the components --- @return XML element converter for a compound value eSeq3 :: String -> (a -> b -> c -> d) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XElemConv d eSeq3 name cons xa xb xc = element name (seq3 cons xa xb xc) --- Creates an XML converter for repetitions of sequences represented as an --- XML element that can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the sequence --- @param conv(s) XML converter for the components --- @return XML element converter for a repeated sequence eRepSeq3 :: String -> (a -> b -> c -> d) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XElemConv [d] eRepSeq3 name cons xa xb xc = element name (repSeq3 cons xa xb xc) seq4_ :: (a -> b -> c -> d -> e) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XmlConv _ NoElem e seq4_ cons xa xb xc xd = Conv rd sh where rd = xmlReads xa />= \a -> xmlReads xb />= \b -> xmlReads xc />= \c -> xmlReads xd />= \d -> ret (cons a b c d) sh arg | (cons a b c d) =:<= arg = xmlShows xa a . xmlShows xb b . xmlShows xc c . xmlShows xd d where a,b,c,d free --- Creates an XML converter representing a sequence of arbitrary XML data. --- The sequence must not be used in repetitions and does not represent an --- XML element. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a sequence seq4 :: (a -> b -> c -> d -> e) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XSeqConv e seq4 = seq4_ --- Creates an XML converter that represents a repetition of a sequence --- of repeatable XML data. The repetition may be used in other --- repetitions and does not represent an XML element. This combinator is --- provided because converters for repeatable sequences cannot be --- constructed by the seq combinators. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a repetition of a sequence repSeq4 :: (a -> b -> c -> d -> e) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XmlConv Repeatable _ d -> XRepConv [e] repSeq4 cons xa xb xc xd = rep (seq4_ cons xa xb xc xd) --- Creates an XML converter for compound values represented as an --- XML element with children that correspond to the values components. --- The element can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the compound value --- @param conv(s) XML converter for the components --- @return XML element converter for a compound value eSeq4 :: String -> (a -> b -> c -> d -> e) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XElemConv e eSeq4 name cons xa xb xc xd = element name (seq4 cons xa xb xc xd) --- Creates an XML converter for repetitions of sequences represented as an --- XML element that can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the sequence --- @param conv(s) XML converter for the components --- @return XML element converter for a repeated sequence eRepSeq4 :: String -> (a -> b -> c -> d -> e) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XmlConv Repeatable _ d -> XElemConv [e] eRepSeq4 name cons xa xb xc xd = element name (repSeq4 cons xa xb xc xd) seq5_ :: (a -> b -> c -> d -> e -> f) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XmlConv _ _ e -> XmlConv _ NoElem f seq5_ cons xa xb xc xd xe = Conv rd sh where rd = xmlReads xa />= \a -> xmlReads xb />= \b -> xmlReads xc />= \c -> xmlReads xd />= \d -> xmlReads xe />= \e -> ret (cons a b c d e) sh arg | (cons a b c d e) =:<= arg = xmlShows xa a . xmlShows xb b . xmlShows xc c . xmlShows xd d . xmlShows xe e where a,b,c,d,e free --- Creates an XML converter representing a sequence of arbitrary XML data. --- The sequence must not be used in repetitions and does not represent an --- XML element. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a sequence seq5 :: (a -> b -> c -> d -> e -> f) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XmlConv _ _ e -> XSeqConv f seq5 = seq5_ --- Creates an XML converter that represents a repetition of a sequence --- of repeatable XML data. The repetition may be used in other --- repetitions and does not represent an XML element. This combinator is --- provided because converters for repeatable sequences cannot be --- constructed by the seq combinators. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a repetition of a sequence repSeq5 :: (a -> b -> c -> d -> e -> f) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XmlConv Repeatable _ d -> XmlConv Repeatable _ e -> XRepConv [f] repSeq5 cons xa xb xc xd xe = rep (seq5_ cons xa xb xc xd xe) --- Creates an XML converter for compound values represented as an --- XML element with children that correspond to the values components. --- The element can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the compound value --- @param conv(s) XML converter for the components --- @return XML element converter for a compound value eSeq5 :: String -> (a -> b -> c -> d -> e -> f) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XmlConv _ _ e -> XElemConv f eSeq5 name cons xa xb xc xd xe = element name (seq5 cons xa xb xc xd xe) --- Creates an XML converter for repetitions of sequences represented as an --- XML element that can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the sequence --- @param conv(s) XML converter for the components --- @return XML element converter for a repeated sequence eRepSeq5 :: String -> (a -> b -> c -> d -> e -> f) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XmlConv Repeatable _ d -> XmlConv Repeatable _ e -> XElemConv [f] eRepSeq5 name cons xa xb xc xd xe = element name (repSeq5 cons xa xb xc xd xe) seq6_ :: (a -> b -> c -> d -> e -> f -> g) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XmlConv _ _ e -> XmlConv _ _ f -> XmlConv _ NoElem g seq6_ cons xa xb xc xd xe xf = Conv rd sh where rd = xmlReads xa />= \a -> xmlReads xb />= \b -> xmlReads xc />= \c -> xmlReads xd />= \d -> xmlReads xe />= \e -> xmlReads xf />= \f -> ret (cons a b c d e f) sh arg | (cons a b c d e f) =:<= arg = xmlShows xa a . xmlShows xb b . xmlShows xc c . xmlShows xd d . xmlShows xe e . xmlShows xf f where a,b,c,d,e,f free --- Creates an XML converter representing a sequence of arbitrary XML data. --- The sequence must not be used in repetitions and does not represent an --- XML element. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a sequence seq6 :: (a -> b -> c -> d -> e -> f -> g) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XmlConv _ _ e -> XmlConv _ _ f -> XSeqConv g seq6 = seq6_ --- Creates an XML converter that represents a repetition of a sequence --- of repeatable XML data. The repetition may be used in other --- repetitions and does not represent an XML element. This combinator is --- provided because converters for repeatable sequences cannot be --- constructed by the seq combinators. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a repetition of a sequence repSeq6 :: (a -> b -> c -> d -> e -> f -> g) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XmlConv Repeatable _ d -> XmlConv Repeatable _ e -> XmlConv Repeatable _ f -> XRepConv [g] repSeq6 cons xa xb xc xd xe xf = rep (seq6_ cons xa xb xc xd xe xf) --- Creates an XML converter for compound values represented as an --- XML element with children that correspond to the values components. --- The element can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the compound value --- @param conv(s) XML converter for the components --- @return XML element converter for a compound value eSeq6 :: String -> (a -> b -> c -> d -> e -> f -> g) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XmlConv _ _ e -> XmlConv _ _ f -> XElemConv g eSeq6 name cons xa xb xc xd xe xf = element name (seq6 cons xa xb xc xd xe xf) --- Creates an XML converter for repetitions of sequences represented as an --- XML element that can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the sequence --- @param conv(s) XML converter for the components --- @return XML element converter for a repeated sequence eRepSeq6 :: String -> (a -> b -> c -> d -> e -> f -> g) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XmlConv Repeatable _ d -> XmlConv Repeatable _ e -> XmlConv Repeatable _ f -> XElemConv [g] eRepSeq6 name cons xa xb xc xd xe xf = element name (repSeq6 cons xa xb xc xd xe xf) curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/index.html.kics2000066400000000000000000000462501305333611600242460ustar00rootroot00000000000000 KiCS2 Libraries

KiCS2: System Libraries

Here is the collection of libraries contained in the distribution of KiCS2. Most of these libraries have been implemented during the development of larger Curry applications. If you have suggestions for changes/improvements or if you want to contribute your own library, please contact Michael Hanus.

General libraries:

Prelude
This is the standard prelude, i.e., the main library which is added to every Curry program.
AllSolutions
This library contains a collection of functions for obtaining lists of solutions to constraints. These operations are useful to encapsulate non-deterministic operations between I/O actions in order to connects the worlds of logic and functional programming and to avoid non-determinism failures on the I/O level.
Assertion
This library defines the datatype and functions for the Curry module tester "currytest".
Char
This library contains some useful functions on characters.
Combinatorial
This library contains a collection of common non-deterministic and/or combinatorial operations.
Constraint
This library contains some useful operations for constraint programming.
CSV
This library supports reading/writing files in CSV (comma separated values) format that can be imported and exported by most spreadsheed and database applications.
Debug
This library contains some useful operation for debugging programs.
Directory
This library supports the access to the directory structure of the underlying operating system.
Distribution
This library contains functions to obtain information concerning the current distribution of the Curry implementation, e.g., compiler version, load paths, front end.
Either
This library contains some useful operation for the Either data type.
FileGoodies
A collection of useful operations when dealing with files.
Float
A collection of operations on floating point numbers.
Function
A collection of utility operations for function application.
FunctionInversion
A collection of utility operations for inverting functions.
Global
This library provides functionality for global entities. A global entity has a name declared in the program. Its value can be accessed and modified by IO actions. Furthermore, global entities can be persistent so that their values are stored across different program executions.
GUI
This library contains definitions and functions to implement graphical user interfaces for Curry programs. It is based on Tcl/Tk and its basic ideas are described in detail here.
Integer
A collection of common operations on integer numbers.
IO
This library contains IO operations, like reading and writing files, that are not already contained in the prelude.
IOExts
This library contains some useful extensions to the IO monad, in particular, the implementation of a global state.
JavaScript
A library to represent JavaScript programs.
KeyDatabaseSQLite
This library provides a general interface for databases where each entry consists of a key and an info part and is stored in a SQLite database.
List
This library contains some useful operations on lists which are not contained in the standard prelude.
Maybe
This library contains some useful operations on the Maybe type which are not contained in the standard prelude.
NamedSocket
This library contains operations for network programming with sockets where sockets are addressed by symbolic names rather than numbers.
Parser
This library defines (functional logic) parser combinators to support a simple implementation of parsers in Curry. It is adapted from Rafael Caballero and Francisco J. Lopez-Fraguas: A Functional Logic Perspective of Parsing, Proc. FLOPS'99, Springer LNCS 1722, pp. 85-99, 1999
Pretty
This library provides combinators to support the definition of pretty printers for structured text.
Profile
This library contains limited and preliminary support for profiling. Currently, it supports the possibility to show the time and space needed to evaluate a term to its normal form.
Prolog
A library to represent Prolog programs.
PropertyFile
This library defines some functions to read and update files containing properties in the usual equational syntax.
Read
This library defines some functions for reading special tokens (naturals, integers, hexadecimal numbers) from strings. This library is included for backward compatibility only. You should use the library ReadNumeric which provides a better interface for these functions.
ReadNumeric
This library defines some functions for reading numeric tokens (naturals, integers, hexadecimal numbers) from strings and converting them to numbers.
ReadShowTerm
This library contains functions for converting ground data terms to strings and vice versa.
SetFunctions
This library contains an implementation of set functions to encapsulate nondeterministic computations. The general idea of set functions is described in this paper.
Socket
This library contains basic operations for network programming with sockets.
System
This library supports the access to parts of the system environment, like the current date and time, environment variables, system calls etc.
Time
This library contains definitions and functions to handle date and time information.
Unsafe
This library contains unsafe operations which should not be used.

Data structures and algorithms:

Array
An implementation of arrays with Braun Trees.
Dequeue
An implementation of double-ended queues supporting access at both ends in constant amortized time.
FiniteMap
An implementation of finite maps. A finite map is an efficient purely functional data structure to store a mapping from keys to values.
GraphInductive
A library for inductive graphs (port of a Haskell library by Martin Erwig). Graphs are composed and decomposed in an inductive way.
Random
This library provides operations for generating pseudo-random number sequences.
RedBlackTree
This library provides an efficient implementation of red-black trees. It serves as the base for the libraries SetRBT and TableRBT. All the operations on trees are generic, i.e., one has to provide explicit order predicates on elements.
SearchTree
This library defines a representation of a search space as a tree and search strategies on this tree.
SetRBT
This library provides an efficient implementation of sets as red-black trees. The implementation is generic in the types of elements and the set operations require an ordering predicate on elements. The library also contains a generic sort function with complexity O(n*log(n)) based on insertion into red-black trees.
Sort
A collection of useful functions for sorting and comparing characters, strings, and lists.
TableRBT
This library provides an efficient implementation of tables (i.e., finite mappings from keys to values) as red-black trees. The implementation is generic in the types of keys and values and the table operations require an ordering predicate on keys.
Traversal
This library supports lightweight generic traversals through tree-structured data.

Libraries for web applications:

CategorizedHtmlList
This library provides functions to categorize a list of entities into a HTML page with an index access (e.g., "A-Z") to these entities.
HTML
This library supports HTML and CGI programming, i.e., the generation of (dynamic) web pages. A detailed description of this library and its basic ideas can be found here.
HtmlParser
This library contains a parser for HTML documents. It does not perform any syntax checks but returns only a generic representation according to the definition of HTML documents provided in the library HTML.
Mail
This library contains functions for sending emails. The implementation might need to be adapted to the local environment.
Markdown
Library to translate markdown documents into HTML or LaTeX.
URL
This library contains functions related to URLs, in particular, downloading of documents accessible by a URL.
WUI
Library to support type-oriented construction of web user interfaces. The ideas behind the application and implementation of this library are described in paper that is available via this web page.
XML
Library for processing data in XML format. It contains a definition of a datatype for representing XML terms and a parser and pretty printing for converting strings into such XML terms and vice versa.
XmlConv
This library provides type-based combinators to construct XML converters. Arbitrary XML data can be represented as algebraic datatypes and vice versa. See here for a description of this library.

Libraries for meta-programming:

AbstractCurry
This library contains a definition for representing Curry programs in Curry and an I/O action to read Curry programs and transform them into this abstract representation.
AbstractCurryGoodies
This library provides some useful functions to write programs that generate AbstractCurry programs more compact and readable.
AbstractCurryPrinter
This library contains a pretty printer for AbstractCurry programs in order to show an AbstractCurry program in standard Curry syntax.
CompactFlatCurry
This library contains functions to reduce the size of FlatCurry programs by combining the main module and all imports into a single program that contains only the functions directly or indirectly called from a set of main functions.
CurryStringClassifier
This library contains a simple tool to process strings containing Curry source code in order to perform simple manipulations of source programs (e.g., adding type signatures, removing comments).
FlatCurry
This library supports meta-programming, i.e., the manipulation of Curry programs in Curry. For this purpose, the library contains definitions of datatypes for the representation of so-called FlatCurry programs and an I/O action to read Curry programs and transform them into this representation.
FlatCurryGoodies
This library provides selector functions, test and update operations as well as some useful auxiliary functions for manipulating FlatCurry data terms.
FlatCurryRead
This library defines operations to read a FlatCurry programs or interfaces together with all its imported modules in the current load path.
FlatCurryShow
This library contains functions to transform FlatCurry programs into string representations, either in a FlatCurry format or in a Curry-like syntax.
FlatCurryXML
This library contains functions to convert FlatCurry programs into XML terms and vice versa.
FlexRigid
This library provides a function to compute the rigid/flex status of a FlatCurry expression (right-hand side of a function definition).
PrettyAbstract
This library contains a pretty printer for AbstractCurry programs in order to show an AbstractCurry program in human-readable Curry syntax. In contrast to the library AbstractCurryPrinter, this library implements a better human-readable pretty printing of AbstractCurry programs.
curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/index.html.pakcs000066400000000000000000000561101305333611600243300ustar00rootroot00000000000000 PAKCS Libraries

PAKCS: System Libraries

Here is the collection of libraries contained in the distribution of PAKCS. Most of these libraries have been implemented during the development of larger Curry applications. If you have suggestions for changes/improvements or if you want to contribute your own library, please contact Michael Hanus.

General libraries:

Prelude
This is the standard prelude, i.e., the main library which is added to every Curry program.
AllSolutions
This library contains a collection of functions for obtaining lists of solutions to constraints. These operations are useful to encapsulate non-deterministic operations between I/O actions in order to connects the worlds of logic and functional programming and to avoid non-determinism failures on the I/O level.
Assertion
This library defines the datatype and functions for the Curry module tester "currytest".
Char
This library contains some useful functions on characters.
CHR
This library defines CHR(Curry), a representation of CHR rules in Curry, an interpreter for CHR rules, and a compiler into CHR(Prolog).
CHRcompiled
This library defines the structure of CHR goals and some constructors to be used in compiled CHR(Curry) rules.
CLPFD
This library supports constraint programming with finite domain constraints.
CLPR
This library supports constraint programming with arithmetic constraints over real numbers.
CLPB
This library provides a Boolean constraint solver based on BDDs.
Combinatorial
This library contains a collection of common non-deterministic and/or combinatorial operations.
Constraint
This library contains some useful operations for constraint programming.
CSV
This library supports reading/writing files in CSV (comma separated values) format that can be imported and exported by most spreadsheed and database applications.
Database
Library for accessing and storing data in databases. The contents of a database is represented in this library as dynamic predicates that are defined by facts than can change over time and can be persistently stored. All functions in this library distinguishes between queries that access the database and transactions that manipulates data in the database. Transactions have a monadic structure. Both queries and transactions can be executed as I/O actions. However, arbitrary I/O actions cannot be embedded in transactions. The ideas of this library are described in this paper.
Debug
This library contains some useful operation for debugging programs.
Directory
This library supports the access to the directory structure of the underlying operating system.
Distribution
This library contains functions to obtain information concerning the current distribution of the Curry implementation, e.g., compiler version, load paths, front end.
Dynamic
This library supports the manipulation of dynamic predicates, i.e., predicates that are defined by facts than can change over time and can be persistently stored. The ideas of this library are described in this paper. Remark: This library has been revised to the library Database. Thus, it might not be further supported in the future.
Either
This library contains some useful operation for the Either data type.
FileGoodies
A collection of useful operations when dealing with files.
Findall
This library contains some operations for encapsulating search which were previously part of the standard prelude. Since there are alternative and better approaches the encpasulate search, e.g., set functions, these operations are now in a separate module in order to keep the standard prelude more portable.
Float
A collection of operations on floating point numbers.
Function
A collection of utility operations for function application.
FunctionInversion
A collection of utility operations for inverting functions.
Global
This library provides functionality for global entities. A global entity has a name declared in the program. Its value can be accessed and modified by IO actions. Furthermore, global entities can be persistent so that their values are stored across different program executions.
GlobalVariable
This library implements global variables. A global variable has a name declared in the program. Its value can be accessed and modified by IO actions. Values of global variables can contain logic variables shared with computations running in the same computation space. As a consequence, values of global variables are not kept across different program executions.
GUI
This library contains definitions and functions to implement graphical user interfaces for Curry programs. It is based on Tcl/Tk and its basic ideas are described in detail here.
Integer
A collection of common operations on integer numbers.
IO
This library contains IO operations, like reading and writing files, that are not already contained in the prelude.
IOExts
This library contains some useful extensions to the IO monad, in particular, the implementation of a global state.
JavaScript
A library to represent JavaScript programs.
KeyDatabaseSQLite
This library provides a general interface for databases (persistent predicates based on the library Database) where each entry consists of a key and an info part.
KeyDatabaseSQLite
This library provides a general interface for databases (persistent predicates based on the library Database) where each entry consists of a key and an info part. It reimplements the interface of the module KeyDatabase based on the SQLite database engine.
KeyDB
This library provides a general interface for databases (persistent predicates) where each entry consists of a key and an info part. Remark: This library has been revised to the library KeyDatabase. Thus, it might not be further supported in the future.
List
This library contains some useful operations on lists which are not contained in the standard prelude.
Maybe
This library contains some useful operations on the Maybe type which are not contained in the standard prelude.
NamedSocket
This library contains operations for network programming with sockets where sockets are addressed by symbolic names rather than numbers.
Parser
This library defines (functional logic) parser combinators to support a simple implementation of parsers in Curry. It is adapted from Rafael Caballero and Francisco J. Lopez-Fraguas: A Functional Logic Perspective of Parsing, Proc. FLOPS'99, Springer LNCS 1722, pp. 85-99, 1999
Ports
This library supports the development of concurrent and distributed applications in Curry by defining ports for sending and receiving messages, possibly containing logical variables. A detailed description of the idea and use of ports can be found here.
Pretty
This library provides combinators to support the definition of pretty printers for structured text.
Profile
This library contains limited and preliminary support for profiling. Currently, it supports the possibility to show the time and space needed to evaluate a term to its normal form.
Prolog
A library to represent Prolog programs.
PropertyFile
This library defines some functions to read and update files containing properties in the usual equational syntax.
Read
This library defines some functions for reading special tokens (naturals, integers, hexadecimal numbers) from strings. This library is included for backward compatibility only. You should use the library ReadNumeric which provides a better interface for these functions.
ReadNumeric
This library defines some functions for reading numeric tokens (naturals, integers, hexadecimal numbers) from strings and converting them to numbers.
ReadShowTerm
This library contains functions for converting ground data terms to strings and vice versa.
SetFunctions
This library contains a prototypical implementation of set functions to encapsulate nondeterministic computations. The general idea of set functions is described in this paper but the implementation in this library is more restricted than the general approach.
Socket
This library contains basic operations for network programming with sockets.
System
This library supports the access to parts of the system environment, like the current date and time, environment variables, system calls etc.
Time
This library contains definitions and functions to handle date and time information.
Unsafe
This library contains unsafe operations which should not be used.

Data structures and algorithms:

Array
An implementation of arrays with Braun Trees.
Dequeue
An implementation of double-ended queues supporting access at both ends in constant amortized time.
FiniteMap
An implementation of finite maps. A finite map is an efficient purely functional data structure to store a mapping from keys to values.
GraphInductive
A library for inductive graphs (port of a Haskell library by Martin Erwig). Graphs are composed and decomposed in an inductive way.
Random
This library provides operations for generating pseudo-random number sequences.
RedBlackTree
This library provides an efficient implementation of red-black trees. It serves as the base for the libraries SetRBT and TableRBT. All the operations on trees are generic, i.e., one has to provide explicit order predicates on elements.
SetRBT
This library provides an efficient implementation of sets as red-black trees. The implementation is generic in the types of elements and the set operations require an ordering predicate on elements. The library also contains a generic sort function with complexity O(n*log(n)) based on insertion into red-black trees.
Sort
A collection of useful functions for sorting and comparing characters, strings, and lists.
TableRBT
This library provides an efficient implementation of tables (i.e., finite mappings from keys to values) as red-black trees. The implementation is generic in the types of keys and values and the table operations require an ordering predicate on keys.
Traversal
This library supports lightweight generic traversals through tree-structured data.

Libraries for web applications:

CategorizedHtmlList
This library provides functions to categorize a list of entities into a HTML page with an index access (e.g., "A-Z") to these entities.
HTML
This library supports HTML and CGI programming, i.e., the generation of (dynamic) web pages. A detailed description of this library and its basic ideas can be found here.
HtmlParser
This library contains a parser for HTML documents. It does not perform any syntax checks but returns only a generic representation according to the definition of HTML documents provided in the library HTML.
Mail
This library contains functions for sending emails. The implementation might need to be adapted to the local environment.
Markdown
Library to translate markdown documents into HTML or LaTeX.
URL
This library contains functions related to URLs, in particular, downloading of documents accessible by a URL.
WUI
Library to support type-oriented construction of web user interfaces. The ideas behind the application and implementation of this library are described in paper that is available via this web page.
XML
Library for processing data in XML format. It contains a definition of a datatype for representing XML terms and a parser and pretty printing for converting strings into such XML terms and vice versa.
XmlConv
This library provides type-based combinators to construct XML converters. Arbitrary XML data can be represented as algebraic datatypes and vice versa. See here for a description of this library.

Libraries for meta-programming:

AbstractCurry
This library contains a definition for representing Curry programs in Curry and an I/O action to read Curry programs and transform them into this abstract representation.
AbstractCurryGoodies
This library provides some useful functions to write programs that generate AbstractCurry programs more compact and readable.
AbstractCurryPrinter
This library contains a pretty printer for AbstractCurry programs in order to show an AbstractCurry program in standard Curry syntax.
CompactFlatCurry
This library contains functions to reduce the size of FlatCurry programs by combining the main module and all imports into a single program that contains only the functions directly or indirectly called from a set of main functions.
CurryStringClassifier
This library contains a simple tool to process strings containing Curry source code in order to perform simple manipulations of source programs (e.g., adding type signatures, removing comments).
FlatCurry
This library supports meta-programming, i.e., the manipulation of Curry programs in Curry. For this purpose, the library contains definitions of datatypes for the representation of so-called FlatCurry programs and an I/O action to read Curry programs and transform them into this representation.
FlatCurryGoodies
This library provides selector functions, test and update operations as well as some useful auxiliary functions for manipulating FlatCurry data terms.
FlatCurryRead
This library defines operations to read a FlatCurry programs or interfaces together with all its imported modules in the current load path.
FlatCurryShow
This library contains functions to transform FlatCurry programs into string representations, either in a FlatCurry format or in a Curry-like syntax.
FlatCurryXML
This library contains functions to convert FlatCurry programs into XML terms and vice versa.
FlexRigid
This library provides a function to compute the rigid/flex status of a FlatCurry expression (right-hand side of a function definition).
PrettyAbstract
This library contains a pretty printer for AbstractCurry programs in order to show an AbstractCurry program in human-readable Curry syntax. In contrast to the library AbstractCurryPrinter, this library implements a better human-readable pretty printing of AbstractCurry programs.
curry-libs-v1.0.3-bf61906d3a2497ba4f3245780ece974526e0964b/test.sh000077500000000000000000000013131305333611600225440ustar00rootroot00000000000000#!/bin/sh # Shell script to test modules having some properties defined CURRYBIN="../bin" ALLTESTS="Combinatorial ShowS Sort" VERBOSE=no if [ "$1" = "-v" ] ; then VERBOSE=yes fi # use the right Curry system for the tests: PATH=$CURRYBIN:$PATH export PATH # clean up before $CURRYBIN/cleancurry CCOPTS="-m100 -dInt" LOGFILE=xxx$$ if [ $VERBOSE = yes ] ; then $CURRYBIN/curry check $CCOPTS $ALLTESTS if [ $? -gt 0 ] ; then exit 1 fi else $CURRYBIN/curry check $CCOPTS $ALLTESTS > $LOGFILE 2>&1 if [ $? -gt 0 ] ; then echo "ERROR in curry check:" cat $LOGFILE exit 1 fi fi ################ end of tests #################### # Clean: /bin/rm -f $LOGFILE *_PUBLIC.curry TEST*.curry