module Data.ArithEncode.Util(
unit,
void,
nonEmptySeq,
nonEmptyOptionSeq,
nonEmptySet,
nonEmptyHashSet,
function,
functionHashable,
relation,
relationHashable,
tree
) where
import Control.Exception
import Data.ArithEncode.Basic
import Data.Hashable
import Data.List
import Data.Maybe
import Data.Set(Set)
import Data.HashMap.Lazy(HashMap)
import Data.HashSet(HashSet)
import Data.Tree
import Prelude hiding (seq)
import qualified Data.HashMap.Lazy as HashMap
import qualified Data.Map as Map
import qualified Data.Set as Set
unit :: Encoding ()
unit = singleton ()
void :: Encoding b
void = mkEncoding (\_ -> throw (IllegalArgument "void encoding"))
(\_ -> throw (IllegalArgument "void encoding"))
(Just 0) (const False)
nonEmptySeq :: Encoding ty
-> Encoding [ty]
nonEmptySeq = nonzero . seq
nonEmptySet :: Ord ty =>
Encoding ty
-> Encoding (Set ty)
nonEmptySet = nonzero . set
nonEmptyHashSet :: (Hashable ty, Ord ty) =>
Encoding ty
-> Encoding (HashSet ty)
nonEmptyHashSet = nonzero . hashSet
nonEmptyOptionSeq :: Encoding ty
-> Encoding [Maybe ty]
nonEmptyOptionSeq enc =
let
fwdfunc Nothing = Just []
fwdfunc (Just (first, rest)) = Just (reverse (Just first : rest))
revfunc' [] = Just Nothing
revfunc' (Just first : rest) = Just (Just (first, rest))
revfunc' _ = Nothing
revfunc = revfunc' . reverse
in
wrap revfunc fwdfunc (optional (pair enc (seq (optional enc))))
nonEmptyBoundedOptionSeq :: Integer
-> Encoding ty
-> Encoding [Maybe ty]
nonEmptyBoundedOptionSeq len enc =
let
fwdfunc Nothing = Just []
fwdfunc (Just (first, rest)) = Just (reverse (Just first : rest))
revfunc' [] = Just Nothing
revfunc' (Just first : rest) = Just (Just (first, rest))
revfunc' _ = Nothing
revfunc = revfunc' . reverse
in
wrap revfunc fwdfunc (optional (pair enc (boundedSeq (len 1) (optional enc))))
function :: Ord keyty =>
Encoding keyty
-> Encoding valty
-> Encoding (Map.Map keyty valty)
function keyenc valenc =
let
seqToMap val =
let
convertEnt (_, Nothing) = Nothing
convertEnt (key', Just val') = Just (decode keyenc key', val')
contents = catMaybes (map convertEnt (zip (iterate (+ 1) 0) val))
in
Just (Map.fromList contents)
mapToSeq val
| all (inDomain keyenc) (Map.keys val) =
let
foldfun (count, accum) (idx, val') =
(idx + 1,
Just val' : replicate (fromInteger (idx count)) Nothing ++ accum)
sorted = sortBy (\(a, _) (b, _) -> compare a b)
(map (\(key, val') -> (encode keyenc key, val'))
(Map.assocs val))
(_, out) = foldl foldfun (0, []) sorted
reversed = reverse out
in
Just reversed
| otherwise = Nothing
innerenc =
case size keyenc of
Just finitesize -> nonEmptyBoundedOptionSeq finitesize valenc
Nothing -> nonEmptyOptionSeq valenc
in
wrap mapToSeq seqToMap innerenc
functionHashable :: (Ord keyty, Hashable keyty) =>
Encoding keyty
-> Encoding valty
-> Encoding (HashMap keyty valty)
functionHashable keyenc valenc =
let
seqToMap val =
let
convertEnt (_, Nothing) = Nothing
convertEnt (key', Just val') = Just (decode keyenc key', val')
contents = catMaybes (map convertEnt (zip (iterate (+ 1) 0) val))
in
Just (HashMap.fromList contents)
mapToSeq val
| all (inDomain keyenc) (HashMap.keys val) =
let
foldfun (count, accum) (idx, val') =
(idx + 1,
Just val' : replicate (fromInteger (idx count)) Nothing ++ accum)
sorted = sortBy (\(a, _) (b, _) -> compare a b)
(map (\(key, val') -> (encode keyenc key, val'))
(HashMap.toList val))
(_, out) = foldl foldfun (0, []) sorted
reversed = reverse out
in
Just reversed
| otherwise = Nothing
innerenc =
case size keyenc of
Just finitesize -> nonEmptyBoundedOptionSeq finitesize valenc
Nothing -> nonEmptyOptionSeq valenc
in
wrap mapToSeq seqToMap innerenc
relation :: (Ord keyty, Ord valty) =>
Encoding keyty
-> Encoding valty
-> Encoding (Map.Map keyty (Set.Set valty))
relation keyenc = function keyenc . nonEmptySet
relationHashable :: (Hashable keyty, Ord keyty, Hashable valty, Ord valty) =>
Encoding keyty
-> Encoding valty
-> Encoding (HashMap keyty (HashSet valty))
relationHashable keyenc = functionHashable keyenc . nonEmptyHashSet
tree :: Encoding ty
-> Encoding (Tree ty)
tree enc =
let
makeNode (label, children) =
Just Node { rootLabel = label, subForest = children }
unmakeNode Node { rootLabel = label, subForest = children } =
Just (label, children)
nodeEncoding nodeenc =
wrap unmakeNode makeNode (pair enc (seq nodeenc))
in
recursive nodeEncoding