Commit 65d80e49 authored by Kai-Oliver Prott's avatar Kai-Oliver Prott
Browse files

Integrate changes needed for CPM libs_refactor

parent 64ff2383
......@@ -18,20 +18,6 @@ module Data.Either
, partitionEithers
) where
-- Either type
data Either a b = Left a | Right b
deriving (Eq, Ord, Show, Read)
instance Functor (Either a) where
fmap _ (Left a) = Left a
fmap f (Right b) = Right (f b)
either :: (a -> c) -> (b -> c) -> Either a b -> c
either f _ (Left x) = f x
either _ g (Right x) = g x
--- Extracts from a list of `Either` all the `Left` elements in order.
lefts :: [Either a b] -> [a]
lefts x = [a | Left a <- x]
......
......@@ -470,7 +470,6 @@ callFrontendWithParams target params modpath = do
showFrontendTarget FCY = "--flat"
showFrontendTarget TFCY = "--typed-flat"
showFrontendTarget TFCY = "--typed-flat"
showFrontendTarget TAFCY = "--type-annotated-flat"
showFrontendTarget FINT = "--flat"
showFrontendTarget ACY = "--acy"
......
......@@ -17,7 +17,7 @@ module Format(showChar,showInt,showFloat,showString) where
import Data.Char
import Data.List
import ReadNumeric
import Numeric
-- Basic type for show functions
type ShowSpec a = Typ -> Maybe Flag -> Maybe Width -> Maybe Precision
......@@ -210,7 +210,7 @@ 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)))
(fst (head (readInt (tail exp))))
getSign :: Floater -> Sign
getSign (Floater s _ _ _) = s
......
......@@ -131,9 +131,19 @@ SearchTreeTraversal -> SearchTree.Traversal
ShowS -> Text.Show
FileGoodies -> Removed
SCC -> Removed
FileGoodies -> Removed and migrated to System.FilePath or System.Directory
seperatorChar removed
pathSeperatorChar -> System.FilePath.pathSeperator
suffixSeperatorChar -> System.FilePath.extSeperator
dirName -> System.FilePath.takeDirectory
baseName -> System.FilePath.takeBaseName
splitDirectoryBaseName -> System.FilePath.splitFileName
stripSuffix -> System.FilePath.dropExtension
fileSuffix -> System.FilePath.takeExtension
splitBaseName -> System.FilePath.splitExtension
splitPath -> System.FilePath.splitPath
lookupFileInPath -> System.Directory.findFileWithSuffix
getFileInPath -> System.Directory.getFileWithSuffix
Nat -> Removed
......@@ -153,6 +163,8 @@ Renames: removed TableRBT suffix
SetRBT -> Data.Set.RBTree
Renames: removed SetRBT suffix
ReadNumeric -> Numeric
Debug -> Debug.Trace
Profile -> Debug.Profile
......
......@@ -6,64 +6,60 @@
--- @category general
------------------------------------------------------------------------------
module ReadNumeric
module Numeric
( readInt, readNat, readHex, readOct, readBin
) where
import Data.Char ( digitToInt, isBinDigit, isOctDigit
, isDigit, isHexDigit, isSpace)
import Data.Maybe
--- 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
--- On success returns `[(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 :: ReadS Int
readInt str = case dropWhile isSpace str of
[] -> Nothing
'-':str1 -> maybe Nothing (\ (val,rstr) -> Just (-val,rstr)) (readNat str1)
[] -> []
'-':str1 -> map (\(n,s) -> (-n, s)) (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
--- On success returns `[(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
readNat :: ReadS Int
readNat str = maybeToList $
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
--- On success returns `[(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
readHex :: ReadS Int
readHex l = maybeToList $
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
--- On success returns `[(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
readOct :: ReadS Int
readOct l = maybeToList $
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
--- On success returns `[(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
readBin :: ReadS Int
readBin l = maybeToList $
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.
......
IOExts
Combinatorial, Findall & Konsorten
PropertyFile (wird in Distribution genutzt)
ReadNumeric
Format
SearchTree
Shows, Reads
......@@ -9,3 +8,5 @@ ValueSequence
Distribution
Array
Traversal
ReadShowTerm
SCC
......@@ -21,7 +21,7 @@ module Prelude
, Num(..), Fractional(..), Real(..), Integral(..)
-- data types
, Bool (..) , Char (..) , Int (..) , Float (..), String , Ordering (..)
, Success, Maybe (..), IO (..), IOError (..)
, Success, Maybe (..), IO (..), IOError (..), Either(..)
, DET
-- functions
, (.), id, const, curry, uncurry, flip, until, seq, ensureNotFree
......@@ -32,7 +32,7 @@ module Prelude
, concat, concatMap, iterate, repeat, replicate, take, drop, splitAt
, takeWhile, dropWhile, span, break, lines, unlines, words, unwords
, reverse, and, or, any, all
, ord, chr, (=:=), success, (&), (&>), maybe
, ord, chr, (=:=), success, (&), (&>), maybe, either
, (>>=), return, (>>), done, putChar, getChar, readFile
, writeFile, appendFile
, putStr, putStrLn, getLine, userError, ioError, showError
......@@ -47,6 +47,7 @@ module Prelude
, Functor(..)
, sequence, sequence_, mapM, mapM_, foldM, liftM, liftM2, forM, forM_
, unlessM, whenM
, pi, (^)
#ifdef __PAKCS__
, (=:<<=), letrec
#endif
......@@ -741,6 +742,15 @@ 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
deriving (Eq, Ord, Show, Read)
either :: (a -> c) -> (b -> c) -> Either a b -> c
either f _ (Left x) = f x
either _ g (Right x) = g x
-- Monadic IO
external data IO _ -- conceptually: World -> (a,World)
......@@ -1796,6 +1806,10 @@ class Functor f where
instance Functor [] where
fmap = map
instance Functor (Either a) where
fmap _ (Left a) = Left a
fmap f (Right b) = Right (f b)
class Monad m where
(>>=) :: m a -> (a -> m b) -> m b
(>>) :: m a -> m b -> m b
......@@ -1887,3 +1901,26 @@ whenM :: Monad m => Bool -> m () -> m ()
whenM p act = if p then act else return ()
----------------------------------------------------------------------------
--some useful numerical operations and constants
infixr 8 ^
--- The number pi.
pi :: Float
pi = 3.141592653589793238
--- 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`.
(^) :: Fractional a => a -> Int -> a
a ^ b | b < 0 = 1 / a ^ (b * (-1))
| otherwise = 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)
------------------------------------------------------------------------------
--- 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 Data.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 <code>show</code>
--- but can read the string back with <code>readUnqualifiedTerm</code>
--- (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 <code>show</code>
--- since it prefixes constructors with their module name
--- in order to read them back with <code>readQTerm</code>.
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: <code>readUnqualifiedTerm ["Prelude"] "Just 3"</code>
--- evaluates to <code>(Just 3)</code>
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))
external_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)
<?xml version="1.0" standalone="no"?>
<!DOCTYPE primitives SYSTEM "http://www.informatik.uni-kiel.de/~pakcs/primitives.dtd">
<primitives>
<primitive name="prim_showQTerm" arity="1">
<library>prim_readshowterm</library>
<entry>prim_showQTerm</entry>
</primitive>
<primitive name="prim_showTerm" arity="1">
<library>prim_readshowterm</library>
<entry>prim_showTerm</entry>
</primitive>
<primitive name="prim_readsQTerm" arity="1">
<library>prim_readshowterm</library>
<entry>prim_readsQTerm</entry>
</primitive>
<primitive name="prim_readsUnqualifiedTerm" arity="2">
<library>prim_readshowterm</library>
<entry>prim_readsUnqualifiedTerm</entry>
</primitive>
</primitives>
--- ----------------------------------------------------------------------------
--- 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 Data.Set.RBTree (empty, member, insert)
data Node a b = Node Int [b] [b] a
deriving Eq
instance (Eq a, Eq b) => Ord (Node a b) where
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 :: (Eq a, Eq b) =>
(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 :: (Eq a, Eq b) => [Node a b] -> [Node a b]
tsort xs = snd (dfs xs empty [])
where
dfs [] marks stack = (marks, stack)
dfs (x : xs') marks stack
| x `member` marks = dfs xs' marks stack
| otherwise = dfs xs' marks' (x : stack')
where
(marks', stack') = dfs (defs x) (x `insert` marks) stack
defs x1 = filter (any (`elem` fvs x1) . bvs) xs
tsort' :: (Eq a, Eq b) => [Node a b] -> [[Node a b]]
tsort' xs = snd (dfs xs empty [])
where
dfs [] marks stack = (marks, stack)
dfs (x : xs') marks stack
| x `member` marks = dfs xs' marks stack
| otherwise = dfs xs' marks' ((x : concat stack') : stack)
where
(marks', stack') = dfs (uses x) (x `insert` marks) []
uses x1 = filter (any (`elem` bvs x1) . fvs) xs
......@@ -65,7 +65,7 @@ module SetFunctions
, values2list, printValues, sortValues, sortValuesBy
) where
import List ( delete, minimum, minimumBy, maximum, maximumBy )
import Data.List ( delete, minimum, minimumBy, maximum, maximumBy )
import Sort ( mergeSortBy )
#ifdef __PAKCS__
import Findall
......
<?xml version="1.0" standalone="no"?>
<!DOCTYPE primitives SYSTEM "http://www.informatik.uni-kiel.de/~pakcs/primitives.dtd">
<primitives>
<primitive name="getCPUTime" arity="0">
<library>prim_system</library>
<entry>prim_getCPUTime</entry>
......
......@@ -73,7 +73,7 @@ module System.FilePath
where
import Data.Char (toLower, toUpper)
import Data.List (isPrefixOf, init, last)
import Data.List (isPrefixOf, init, last, intersperse)
import Data.Maybe (isJust, fromJust)
import System.Environment (getEnv, isPosix, isWindows)
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment