Commit c1846b22 authored by Mart Lubbers's avatar Mart Lubbers Committed by Steffen Michels

Foldable default

parent 833dd00e
implementation module Clean.Types.Tree
import StdBool
from StdFunc import o
import StdInt
import StdFunctions
import StdOrdList
import StdOverloaded
import StdString
import StdTuple
import Clean.Types
import Clean.Types.Unify
......
......@@ -2,7 +2,9 @@ implementation module Clean.Types.Util
import StdArray
import StdBool
from StdFunc import flip, id, o
import StdChar
import StdFunctions
import StdInt
import StdMisc
import StdOrdList
import StdString
......@@ -11,9 +13,8 @@ import StdTuple
import Clean.Types
import Control.Applicative
import Control.Monad
from Data.Func import $
import Data.Func
import Data.Functor
import Data.GenEq
import Data.List
from Data.Map import :: Map(..), get
import Data.Maybe
......
......@@ -5,10 +5,13 @@ from Control.Applicative import class pure(pure), class <*>, class Applicative,
from Control.Monad import class Monad(bind), >>=, class MonadPlus(mzero,mplus)
from Data.Functor import class Functor
from Data.Monoid import class Monoid, class Semigroup
from Data.Maybe import :: Maybe
from Data.Maybe import :: Maybe(..)
from StdOverloaded import class +, class one, class *, class zero, class <, class ==
from Data.List import instance Foldable []
from StdClass import class Ord
from StdFunc import flip
from StdMisc import abort
from Data.Monoid import :: Endo(Endo), :: Dual(Dual), class Monoid(mempty), class Semigroup(mappend), appEndo, getDual
from StdFunc import flip, id
/**
* Ported from Haskell's Data.Foldable by Jurriën Stutterheim 15-08-2014
......@@ -40,50 +43,75 @@ class Foldable t where
/**
* Combine the elements of a structure using a monoid.
*/
fold :: !(t m) -> m | Monoid m
fold :: !(t m) -> m | Monoid m
fold a = foldMap id a
/**
* Map each element of the structure to a monoid, and combine the results.
*/
foldMap :: (a -> m) !(t a) -> m | Monoid m
foldMap :: (a -> m) !(t a) -> m | Monoid m
foldMap f t = foldr (\x->mappend (f x)) mempty t
/**
* Right-associative fold of a structure.
* `foldr f z = 'StdList'.{{foldr}} f z {{o}} {{toList}}`
*/
foldr :: (a .b -> .b) .b !(t a) -> .b
foldr :: (a .b -> .b) .b !(t a) -> .b
foldr f z t = appEndo (foldMap (Endo f) t) z
/**
* Right-associative fold of a structure, but with strict application of
* the operator.
*/
foldr` :: (a .b -> .b) !.b !(t a) -> .b
foldr` :: (a .b -> .b) !.b !(t a) -> .b
foldr` f z0 xs = foldl (\k x z->sapp k (f x z)) (\x.x) xs z0
where
sapp :: .(.a -> .b) !.a -> .b
sapp f x = f x
/**
* Left-associative fold of a structure.
* `foldl f z = 'StdList'.{{foldl}} f z o {{toList}}`
*/
foldl :: (.b -> .(a -> .b)) .b !(t a) -> .b
foldl :: (.b -> .(a -> .b)) .b !(t a) -> .b
foldl f z t = appEndo (getDual (foldMap (\x->Dual (Endo (flip f x))) t)) z
/**
* Left-associative fold of a structure, but with strict application of the
* operator.
*/
foldl` :: (.b -> .(a -> .b)) !.b !(t a) -> .b
foldl` :: (.b -> .(a -> .b)) !.b !(t a) -> .b
foldl` f z0 xs = foldr (\x k z->sapp k (f z x)) (\x.x) xs z0
where
sapp :: .(.a -> .b) !.a -> .b
sapp f x = f x
/**
* A variant of {{foldr}} that has no base case, and thus may only be
* applied to non-empty structures.
* `foldr1 f = 'Data.List'.{{foldr1}} f o {{toList}}`
*/
foldr1 :: !(a a -> a) !(t a) -> a
foldr1 :: !(a a -> a) !(t a) -> a
foldr1 f x = case foldr mf Nothing x of
Nothing = abort "foldr1: empty structure\n"
Just x = x
where
mf x m = Just (case m of
Nothing -> x
Just y -> f x y)
/**
* A variant of {{foldl}} that has no base case, and thus may only be
* applied to non-empty structures.
* `foldl1 f = 'Data.List'.{{foldl1}} f o {{toList}}`
*/
foldl1 :: !(a a -> a) !(t a) -> a
foldl1 :: !(a a -> a) !(t a) -> a
foldl1 f x = case foldl mf Nothing x of
Nothing = abort "foldl1: empty structure\n"
Just x = x
where
mf m y = Just (case m of
Nothing -> y
Just x -> f x y)
// TODO Cleanify
//instance Ix i => Foldable (Array i)
......
......@@ -6,6 +6,7 @@ import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Internal.Thread
import Data.List
import StdList
from StdFunc import o
import StdTuple
......
......@@ -9,7 +9,7 @@ import qualified Data.IntSet
import qualified Data.List
//import Data.Maybe (fromMaybe, isJust)
//import Data.Monoid (mappend)
import StdBool, StdTuple, StdFunc, StdMisc, StdEnum, StdString, StdOverloaded, StdClass
import StdList, StdBool, StdTuple, StdFunc, StdMisc, StdEnum, StdString, StdOverloaded, StdClass
import Data.List
import Data.Maybe
import Data.Functor
......
......@@ -4,7 +4,7 @@ implementation module Data.Graph.Inductive.Internal.RootPath
import Data.Graph.Inductive.Graph
import Data.List
import StdFunc, StdTuple
import StdFunc, StdTuple, StdInt
:: LRTree a :== [LPath a]
:: RTree :== [Path]
......
......@@ -34,7 +34,7 @@ fromGraph :: (g a b) -> NodeMap a | Ord a & Graph g
fromGraph g =
let ns = 'Data.Graph.Inductive.Graph'.labNodes g
aux (n, a) (m`, k`) = ('Data.Map'.put a n m`, max n k`)
(m, k) = 'Data.List'.foldr aux ('Data.Map'.newMap, 0) ns
(m, k) = foldr aux ('Data.Map'.newMap, 0) ns
in {NodeMap | map = m, key = k+1 }
// | Generate a labelled node from the given label. Will return the same node
......
......@@ -3,7 +3,7 @@
implementation module Data.Graph.Inductive.Query.BFS
import StdMisc,StdBool, StdFunc
import StdMisc,StdBool, StdFunc, StdInt
import Data.List
import Data.Maybe
import Data.Graph.Inductive.Graph
......
......@@ -28,7 +28,7 @@ import StdOrdList
import Data.List
import Data.Maybe
import StdTuple, StdMisc, StdFunc
import StdInt, StdTuple, StdMisc, StdFunc
import Data.Graph.Inductive.Basic
import Data.Graph.Inductive.Graph
......
......@@ -3,7 +3,7 @@
implementation module Data.Graphviz
import StdArray, StdOverloaded, StdOrdList, StdTuple, StdString, StdBool, StdMisc
import StdEnv
import Data.Maybe, Data.List
import Text.GenPrint, Data.GenEq
......
......@@ -8,7 +8,7 @@ from StdFunc import id
from Text.GenJSON import generic JSONEncode, generic JSONDecode, :: JSONNode
from Data.GenEq import generic gEq
from Data.Monoid import class Monoid, class Semigroup
from Data.List import foldr
from StdList import foldr
from Data.Functor import class Functor (..)
from Data.IntMap.Base import :: IntMap (..), :: Mask, :: Prefix, minViewWithKey, maxViewWithKey, empty, lookup, instance == (IntMap a), equal
......
......@@ -88,7 +88,7 @@ import StdInt, StdBool, StdFunc, StdMisc, StdOverloaded, StdClass, StdTuple
import Data.GenLexOrd
import Data.Maybe
import Data.Monoid
import qualified Data.List
import qualified StdList
//import Data.Semigroup
//import Data.Utils.BitUtil
//import Data.Utils.StrictFold
......@@ -306,7 +306,7 @@ deleteBM _ _ Nil = Nil
// | The union of a list of sets.
unions :: [IntSet] -> IntSet
unions xs
= 'Data.List'.foldl union empty xs
= 'StdList'.foldl union empty xs
// | /O(n+m)/. The union of two sets.
......@@ -655,7 +655,7 @@ deleteMax s = (maybe Nil snd o maxView) s
// for some =:(x,y)=:, =:x \<> y && f x == f y=:
map :: (Key -> Key) IntSet -> IntSet
map f s = (fromList o 'Data.List'.map f o toList) s
map f s = (fromList o 'StdList'.map f o toList) s
/* ------------------------------------------------------------------
Fold
......@@ -760,7 +760,7 @@ toDescList s = foldl (\xs x -> [x:xs]) [] s
// | /O(n*min(n,W))/. Create a set from a list of integers.
fromList :: [Key] -> IntSet
fromList xs
= 'Data.List'.foldl ins empty xs
= 'StdList'.foldl ins empty xs
where
ins t x = insert x t
......
definition module Data.List
from StdClass import class Ord, class Eq, class IncDec
from StdOverloaded import class ==, class <, class length, class %, class toString, class toChar, class fromString, class fromChar, class +, class *, class /, class *, class /, class *, class /, class *, class /, class zero, class one, class -
import StdList
from Data.GenEq import generic gEq
from Data.Functor import class Functor
from Data.Maybe import :: Maybe
......
......@@ -3,7 +3,8 @@ implementation module Data.List
import StdBool
import StdEnum
import StdFunctions
import StdList
from StdList import ++, prod, isMember, any, scan, last, filter, zip, hd, tl, isEmpty, span, drop, map, flatten, repeat, take, reverse, zip2, instance length []
import qualified StdList
import StdMisc
import StdOrdList
import StdTuple
......@@ -12,7 +13,7 @@ import Data.Functor
import Data.GenEq
import Data.Maybe
import Data.Monoid
from Data.Foldable import class Foldable(foldMap, foldl1, foldr1)
from Data.Foldable import class Foldable(..)
from Data.Traversable import class Traversable(..)
import Control.Applicative
from Control.Monad import class Monad(..)
......@@ -35,7 +36,7 @@ instance Alternative [] where
instance Monad []
where
bind m k = foldr ((++) o k) [] m
bind m k = 'StdList'.foldr ((++) o k) [] m
instance MonadPlus []
where
......@@ -52,31 +53,19 @@ where
instance Foldable []
where
fold x = foldMap id x
foldMap f x = foldr (mappend o f) mempty x
foldr f x y = foldr f x y
foldr a b c = 'StdList'.foldr a b c
foldr` f x y = strictFoldr f x y
where
strictFoldr :: !(.a -> .(.b -> .b)) !.b ![.a] -> .b
strictFoldr _ b [] = b
strictFoldr f b [x:xs] = f x (strictFoldr f b xs)
foldl f x y = foldl f x y
foldl` f x y = strictFoldl f x y
where
strictFoldl :: !(.a -> .(.b -> .a)) !.a ![.b] -> .a
strictFoldl _ b [] = b
strictFoldl f b [x:xs] = strictFoldl f (f b x) xs
foldr1 _ [x] = x
foldr1 f [x:xs] = f x (foldr1 f xs)
foldr1 _ _ = abort "foldr1 called with empty list\n"
foldl1 f [x:xs] = foldl f x xs
foldl1 _ _ = abort "foldl1 called with empty list\n"
instance Traversable []
where
traverse f x = foldr (\x ys->(\x xs->[x:xs]) <$> f x <*> ys) (pure []) x
......@@ -149,14 +138,14 @@ subsequences xs = [[] : nonEmptySubsequences xs]
nonEmptySubsequences :: .[a] -> .[[a]]
nonEmptySubsequences [] = []
nonEmptySubsequences [x:xs] = [[x] : foldr f [] (nonEmptySubsequences xs)]
nonEmptySubsequences [x:xs] = [[x] : 'StdList'.foldr f [] (nonEmptySubsequences xs)]
where f ys r = [ys : [x : ys] : r]
permutations :: [a] -> .[[a]]
permutations xs0 = [xs0 : perms xs0 []]
where
perms [] _ = []
perms [t:ts] is = foldr interleave (perms ts [t:is]) (permutations is)
perms [t:ts] is = 'StdList'.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 o (\xs -> [y:xs])) ys r
......@@ -266,7 +255,7 @@ find :: (a -> .Bool) -> .(.[a] -> .(Maybe a))
find p = listToMaybe o filter p
partition :: !(a -> .Bool) !.[a] -> (!.[a], !.[a])
partition p xs = foldr (select p) ([],[]) xs
partition p xs = 'StdList'.foldr (select p) ([],[]) xs
select :: !.(a -> .Bool) !a !(!u:[a], !v:[a]) -> (!w:[a], !x:[a]), [u <= w,v <= x]
select p x (ts, fs)
......
......@@ -74,7 +74,6 @@ from Data.GenEq import generic gEq
from Data.GenLexOrd import generic gLexOrd, :: LexOrd
from Data.Monoid import class Monoid, class Semigroup
import qualified StdList
from Data.List import foldr
from Data.Functor import class Functor (..)
from StdOverloaded import class < (..)
import StdClass
......
implementation module Data.Map
from StdBool import &&, ||
from StdFunc import id, flip, o, const, seq
from StdTuple import snd
from StdMisc import abort, undef
import StdString, StdTuple
from Data.GenEq import generic gEq
import Data.Maybe, Text.GenJSON, Data.GenLexOrd
from Data.Set import :: Set
import Data.Monoid, Data.Functor, Control.Applicative
import Data.List, Data.Either
from Data.Foldable import class Foldable
from Data.Traversable import class Traversable
import StdClass
import StdBool
import StdFunctions
import StdOverloaded
import StdMisc
import StdInt
import StdString
import StdTuple
import Data.Either
import Data.GenLexOrd
import Data.Maybe
import Data.Monoid
import Data.Functor
import Data.List
import Control.Applicative
import Control.Monad
import Text.GenJSON
import qualified Data.Set
from Data.Set import :: Set
// Ported from Haskell`s Data.Map by Jurriën Stutterheim, 10-09-2014
......
implementation module Data.MapCollection
import StdList
import Data.List
from Data.Maybe import :: Maybe (..), fromJust, maybeToList
from Data.Map import :: Map
......
......@@ -68,7 +68,8 @@ from Data.Maybe import :: Maybe
from StdBool import not, &&
from Data.GenEq import generic gEq
from Data.GenLexOrd import generic gLexOrd, :: LexOrd
from Data.Foldable import class Foldable (foldr`)
import qualified Data.Foldable
from Data.Foldable import class Foldable
/**
* A `Set a` is an unordered, uncounted collection of values of type `a`.
......@@ -437,7 +438,7 @@ toList s :== toAscList s
* @complexity O(n)
* @type (Set a) -> [a]
*/
toAscList t :== foldr` (\a as -> [a:as]) [] t
toAscList t :== 'Data.Foldable'.foldr` (\a as -> [a:as]) [] t
/**
* Create a set from a list of elements.
......
......@@ -3,6 +3,7 @@ implementation module Data.Set
import StdClass, StdMisc, StdBool, StdFunc, StdInt, StdTuple
import Data.Maybe, Data.GenEq, Data.GenLexOrd, Data.Monoid
from Data.Foldable import class Foldable (..)
import Data.Func
import qualified StdList
from StdList import instance == [a]
......@@ -21,49 +22,26 @@ instance == (Set a) | == a where
(==) :: !(Set a) !(Set a) -> Bool | == a
(==) t1 t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
instance < (Set a) | < a where
(<) :: !(Set a) !(Set a) -> Bool | < a
(<) s1 s2 = compare (toAscList s1) (toAscList s2)
where
compare :: ![a] ![a] -> Bool | < a
compare [] [] = False
compare [] _ = True
compare [_:_] [] = False
compare [a:as] [b:bs]
| a < b = True
| a > b = False
| otherwise = compare as bs
instance < (Set a) | < a
where
(<) :: !(Set a) !(Set a) -> Bool | < a
(<) s1 s2 = compare (toAscList s1) (toAscList s2)
where
compare :: ![a] ![a] -> Bool | < a
compare [] [] = False
compare [] _ = True
compare [_:_] [] = False
compare [a:as] [b:bs]
| a < b = True
| a > b = False
| otherwise = compare as bs
gEq{|Set|} eEq x y = (size x == size y) && gEq{|* -> *|} eEq (toAscList x) (toAscList y)
gLexOrd{|Set|} eLexOrd x y = gLexOrd{|* -> *|} eLexOrd (toAscList x) (toAscList y)
instance Foldable Set where
fold x = foldMap id x
foldMap f x = foldr (mappend o f) mempty x
foldr _ z Tip = z
foldr f z (Bin _ x l r) = foldr f (f x (foldr f z r)) l
foldr` _ z Tip = z
foldr` f z (Bin _ x l r) = foldr` f (f x (foldr` f z r)) l
foldl _ z Tip = z
foldl f z (Bin _ x l r) = foldl f (f (foldl f z l) x) r
foldl` _ z Tip = z
foldl` f z (Bin _ x l r) = foldl` f (f (foldl` f z l) x) r
foldr1 f (Bin _ x Tip Tip) = x
foldr1 f (Bin _ x Tip r) = foldr f x r
foldr1 f (Bin _ x l Tip) = foldr f x l
foldr1 f (Bin _ x l r) = foldr f (f x (foldr1 f r)) l
foldr1 _ Tip = abort "foldr1 called with Tip\n"
foldl1 f (Bin _ x Tip Tip) = x
foldl1 f (Bin _ x Tip r) = foldl f x r
foldl1 f (Bin _ x l Tip) = foldl f x l
foldl1 f (Bin _ x l r) = foldl f (f (foldr1 f l) x) r
foldl1 _ Tip = abort "foldl1 called with Tip\n"
foldr _ z Tip = z
foldr f z (Bin _ x l r) = foldr f (f x (foldr f z r)) l
/*--------------------------------------------------------------------
* Query
......
implementation module Data.Tree
// Ported from Haskell's Data.Tree by Jurriën Stutterheim
from Data.Functor import class Functor (..), <$>
from Control.Applicative import class pure(..), class <*>(..), class Applicative
from Control.Monad import class Monad (..), liftM, `b`, mapM
from Data.Monoid import class Monoid (..), class Semigroup
from StdList import map, ++
from StdOverloaded import class +++ (..)
from StdFunc import o
import StdMisc
from Data.List import zipWith, iterate, foldr, repeat, concatMap, takeWhile, isEmpty
from StdBool import not
import StdString
import StdEnv
import Data.Functor
import Data.Monoid
import Data.List
import Control.Applicative
import Control.Monad
rootLabel :: (RTree a) -> a
rootLabel (RNode x _) = x
......
implementation module Data.Tuple
from StdFunc import id, o
from StdMisc import abort
import StdFunc
import StdMisc
import Data.Bifunctor
import Data.Functor
import Data.Maybe
......
implementation module Graphics.Scalable.Internal.Image`
import _SystemArray
from StdBool import &&, ||
from StdFunc import o, seqList, :: St (..)
from StdMisc import abort
from StdOrdList import minList, maxList
import StdMisc
import StdBool
import StdFunc
import StdClass
import StdTuple
import StdOverloaded
import StdString
from StdTuple import fst, snd
import StdInt
import StdReal
import StdOrdList
import Data.List
import Data.GenEq
from Data.Set import :: Set, instance == (Set a), instance < (Set a), instance Foldable Set, fromList, toList, toAscList
from Data.Map import :: Map, findKeyWith
from Data.Maybe import :: Maybe (..), fromJust, maybeToList, instance Functor Maybe, instance == (Maybe a)
import Data.Maybe
import Data.Error
from Data.Functor import class Functor (..)
from Data.Foldable import class Foldable (foldl1, foldr`)
from Control.Applicative import class Applicative
import Control.Monad
import Data.Functor
import Data.Monoid
import Data.MapCollection
from Text.HTML import :: SVGColor (..)
import Math.Geometry
import Graphics.Scalable.Types
import Graphics.Scalable.Internal.Types
import qualified Data.Foldable
import qualified Data.Set
from Data.Set import instance Foldable Set
import qualified Data.Map
:: Image` m
......@@ -675,7 +677,7 @@ where
attr` (MaskAttr` mask) image font_spans text_spans imgTables=:{ImgTables | imgUniqIds = no}
#! (img,imgTables) = toImg image font_spans text_spans {ImgTables | imgTables & imgUniqIds = no-1}
#! (m`, imgTables=:{ImgTables | imgMasks = curMasks, imgSpans = curSpans}) = toImg mask font_spans text_spans imgTables
#! (mask_key,masks) = case findKeyWith (equivImg m`) curMasks of
#! (mask_key,masks) = case 'Data.Map'.findKeyWith (equivImg m`) curMasks of
Just k = (k, curMasks) // similar mask already present, so use it's identification
nothing = (m`.Img.uniqId, 'Data.Map'.put m`.Img.uniqId m` curMasks) // similar mask not yet present, so add it to mask collection
= ( mkTransformImg no img (MaskImg mask_key) // this *must* be the id of the mask image, because for that an svg-definition is generated
......@@ -767,13 +769,13 @@ spanImgTexts text_spans span txts
LookupSpan (TextXSpan font str) = case lookupTextSpan font str text_spans of
Just w = (PxSpan w,txts)
no_info = (span, addToMapSet font str txts)
AddSpan sp1 sp2 = spanImgTexts` text_spans (foldl1 (+)) [sp1,sp2] txts
SubSpan sp1 sp2 = spanImgTexts` text_spans (foldl1 (-)) [sp1,sp2] txts
MulSpan sp1 sp2 = spanImgTexts` text_spans (foldl1 (*)) [sp1,sp2] txts
DivSpan sp1 sp2 = spanImgTexts` text_spans (foldl1 (/)) [sp1,sp2] txts
AbsSpan sp = spanImgTexts` text_spans (abs o hd) [sp] txts
MinSpan sps = spanImgTexts` text_spans minSpan sps txts
MaxSpan sps = spanImgTexts` text_spans maxSpan sps txts
AddSpan sp1 sp2 = spanImgTexts` text_spans ('Data.Foldable'.foldl1 (+)) [sp1,sp2] txts
SubSpan sp1 sp2 = spanImgTexts` text_spans ('Data.Foldable'.foldl1 (-)) [sp1,sp2] txts
MulSpan sp1 sp2 = spanImgTexts` text_spans ('Data.Foldable'.foldl1 (*)) [sp1,sp2] txts
DivSpan sp1 sp2 = spanImgTexts` text_spans ('Data.Foldable'.foldl1 (/)) [sp1,sp2] txts
AbsSpan sp = spanImgTexts` text_spans (abs o hd) [sp] txts
MinSpan sps = spanImgTexts` text_spans minSpan sps txts
MaxSpan sps = spanImgTexts` text_spans maxSpan sps txts