Commit 36c17fcd authored by Mart Lubbers's avatar Mart Lubbers

Fix _Array buggery

parent 28796b2f
Pipeline #15384 failed with stage
in 1 minute and 6 seconds
......@@ -2,7 +2,7 @@ implementation module Codec.Compression.Snappy
import StdEnv
import System._Pointer
import System._Pointer, Data._Array
import Text
snappy_max_compressed_length :: !Int -> Int
......@@ -24,7 +24,7 @@ where
snappy_compress :: !.String -> .String
snappy_compress s
#! n = snappy_max_compressed_length (size s)
#! c = createArray (n+1) '\0'
#! c = unsafeCreateArray (n+1)
#! (r,len) = compress s (size s) c
| r <> 0 = abort ("Invalid return status of snappy_compress: " <+ r <+ "\n")
= {c \\ c <-: c & i <- [0..len-1]}
......
implementation module Control.GenMapSt
import StdGeneric, StdEnv, Data.Array
derive bimap (,)
import StdGeneric, StdEnv, Data.Array, Data._Array
generic gMapLSt a b :: .a .st -> (.b, .st)
gMapLSt{|c|} x st = (x, st)
gMapLSt{|UNIT|} _ st = (UNIT, st)
gMapLSt{|PAIR|} fx fy (PAIR x y) st
# (x, st) = fx x st
# (y, st) = fy y st
= (PAIR x y, st)
# (x, st) = fx x st
# (y, st) = fy y st
= (PAIR x y, st)
gMapLSt{|EITHER|} fl fr x st = mapStEITHER fl fr x st
gMapLSt{|CONS|} f x st = mapStCONS f x st
gMapLSt{|FIELD|} f x st = mapStFIELD f x st
......@@ -23,31 +21,59 @@ derive gMapLSt [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
generic gMapRSt a b :: .a .st -> (.b, .st)
gMapRSt{|c|} x st = (x, st)
gMapRSt{|UNIT|} _ st = (UNIT, st)
gMapRSt{|PAIR|} fx fy (PAIR x y) st
# (y, st) = fy y st
# (x, st) = fx x st
= (PAIR x y, st)
gMapRSt{|EITHER|} fx fy x st = mapStEITHER fx fy x st
gMapRSt{|PAIR|} fx fy (PAIR x y) st
# (y, st) = fy y st
# (x, st) = fx x st
= (PAIR x y, st)
gMapRSt{|EITHER|} fx fy x st = mapStEITHER fx fy x st
gMapRSt{|CONS|} f x st = mapStCONS f x st
gMapRSt{|FIELD|} f x st = mapStFIELD f x st
gMapRSt{|OBJECT|} f x st = mapStOBJECT f x st
gMapRSt{|{}|} f x st = mapArrSt f x st
gMapRSt{|{!}|} f x st = mapArrSt f x st
gMapRSt{|{}|} f x st = mapArrayRSt f x st
gMapRSt{|{!}|} f x st = mapArrayRSt f x st
derive gMapRSt [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
mapStEITHER fl fr (LEFT x) st
# (x, st) = fl x st
# (x, st) = fl x st
= (LEFT x, st)
mapStEITHER fl fr (RIGHT x) st
# (x, st) = fr x st
# (x, st) = fr x st
= (RIGHT x, st)
mapStCONS f (CONS x) st
# (x, st) = f x st
# (x, st) = f x st
= (CONS x, st)
mapStFIELD f (FIELD x) st
# (x, st) = f x st
= (FIELD x, st)
mapStOBJECT f (OBJECT x) st
# (x, st) = f x st
= (OBJECT x, st)
mapStFIELD f (FIELD x) st
# (x, st) = f x st
= (FIELD x, st)
mapStOBJECT f (OBJECT x) st
# (x, st) = f x st
= (OBJECT x, st)
mapArrayLSt f xs st
#! (size_xs, xs) = usize xs
#! (xs, ys, st) = map f 0 size_xs xs (unsafeCreateArray size_xs) st
= (ys, st)
where
map f i n xs ys st
| i == n
= (xs, ys, st)
| otherwise
#! (x, xs) = unsafeUselect xs i
#! (y, st) = f x st
#! ys = update ys i y
= map f (inc i) n xs ys st
mapArrayRSt f xs st
#! (size_xs, xs) = usize xs
#! (xs, ys, st) = map f (size_xs - 1) xs (unsafeCreateArray size_xs) st
= (ys, st)
where
map f i xs ys st
| i < 0
= (xs, ys, st)
| otherwise
#! (x, xs) = unsafeUselect xs i
#! (y, st) = f x st
#! ys = update ys i y
= map f (dec i) xs ys st
implementation module Control.GenReduce
import StdGeneric
import StdGeneric, StdEnv, Data.Array, Data._Array
// or crush
generic gReduce t :: (a a -> a) a t -> a
......@@ -42,3 +42,29 @@ derive gReduceLSt [], (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
reduceEITHER fl fr (LEFT x) st = fl x st
reduceEITHER fl fr (RIGHT x) st = fr x st
reduceArrayLSt :: (u:a -> .(.b -> .b)) v:(c u:a) .b -> .b | Array c a, [v <= u]
reduceArrayLSt f xs st
#! (size_xs, xs) = usize xs
#! (xs, st) = reduce f 0 size_xs xs st
= st
where
reduce f i n xs st
| i == n
= (xs, st)
| otherwise
#! (x, xs) = unsafeUselect xs i
= reduce f (inc i) n xs (f x st)
reduceArrayRSt :: (u:a -> .(.b -> .b)) v:(c u:a) .b -> .b | Array c a, [v <= u]
reduceArrayRSt f xs st
#! (size_xs, xs) = usize xs
#! (xs, st) = reduce f (dec size_xs) xs st
= st
where
reduce f i xs st
| i < 0
= (xs, st)
| otherwise
#! (x, xs) = unsafeUselect xs i
= reduce f (dec i) xs (f x st)
......@@ -35,3 +35,5 @@ instance +++ (arr a) | Array arr a
instance Functor {}, {!}
instance Applicative {}, {!}
instance Monad {}, {!}
reduceArray :: ((.a -> u:(b -> b)) -> .(b -> .(c -> .a))) (.a -> u:(b -> b)) b .(d c) -> b | Array d c
......@@ -130,3 +130,13 @@ where
instance Monad {} where bind m k = foldrArr ((+++) o k) {} m
instance Monad {!} where bind m k = foldrArr ((+++) o k) {} m
reduceArray :: ((.a -> u:(b -> b)) -> .(b -> .(c -> .a))) (.a -> u:(b -> b)) b .(d c) -> b | Array d c
reduceArray f op e xs
= reduce f 0 (size xs) op e xs
where
reduce f i n op e xs
| i == n
= e
| otherwise
= op (f op e xs.[i]) (reduce f (inc i) n op e xs)
......@@ -2,6 +2,7 @@ implementation module Data.GenCompress
import StdGeneric, StdEnv
from Data.Maybe import :: Maybe(..)
import Data._Array
//--------------------------------------------------
// uncompressor monad
......@@ -129,7 +130,7 @@ foldSt f [x:xs] = foldSt f xs o f x
uncompressArray :: (u:CompressSt -> ((Maybe v:a),w:CompressSt)) -> .(x:CompressSt -> ((Maybe y:(b v:a)),z:CompressSt)) | Array b a, [x w <= u,y <= v,x w <= z]
uncompressArray f
= uncompressInt >>= \s -> uncompress_array 0 s {undef\\_<-[0..s]}
= uncompressInt >>= \s -> uncompress_array 0 s (unsafeCreateArray s)
where
uncompress_array i s arr
| i == s
......
definition module Data._Array
from StdArray import class Array
unsafeCreateArray :: .Int -> u:(a v:b) | Array a b, [u<=v]
unsafeUselect :: u:(a v:b) Int -> *(v:b,u:(a v:b)) | Array a b, [u<=v]
implementation module Data._Array
import StdEnv
unsafeCreateArray :: .Int -> u:(a v:b) | Array a b, [u<=v]
unsafeCreateArray size = code {
updatepop_a 0 7
jmp_ap 1
}
unsafeUselect :: u:(a v:b) Int -> *(v:b,u:(a v:b)) | Array a b, [u<=v]
unsafeUselect arr index = code {
push_a 0
select _ 1 0
}
......@@ -92,6 +92,7 @@ import qualified Data.GenEq
import qualified Data.GenFDomain
import qualified Data.GenLexOrd
import qualified Data.GenZip
import qualified Data.Generics
import qualified Data.Graph
import qualified Data.Graph.Inductive
import qualified Data.Graph.Inductive.Basic
......@@ -133,7 +134,7 @@ import qualified Data.Traversable
import qualified Data.Tree
import qualified Data.Tuple
import qualified Data.Word8
import qualified Data.Generics
import qualified Data._Array
import qualified Database.Native
import qualified Database.Native.JSON
import qualified Database.SQL
......
Markdown is supported
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