Sets.hs

{-# LANGUAGE OverloadedStrings #-}

module Funcons.Core.Values.Composite.Collections.Sets where

import Funcons.EDSL
import Funcons.Core.Values.Primitive.BoolBuiltin

import qualified Data.Set as S

library = libFromList [
        ("set", ValueOp stepSet)
    ,   ("set-empty", NullaryFuncon (rewritten (Set S.empty)))
    ,   ("set-insert", ValueOp stepSet_Insert)
    ,   ("set-unite", ValueOp set_unite_op)
    ,   ("set-intersect", ValueOp set_intersect_op)
    ,   ("set-difference", ValueOp set_difference_op)
    ,   ("set-size", ValueOp set_size_op)
    ,   ("is-in-set", ValueOp stepIsInSet)
    ,   ("some-element", ValueOp stepSome_Element)
    ,   ("is-set-empty", ValueOp is_set_empty_op)
    ,   ("set-to-list", ValueOp stepSetToList)
    ,   ("list-to-set", ValueOp stepList_To_Set)
    ,   ("is-subset", ValueOp stepIs_Subset)
    ]

set_to_list = applyFuncon "set-to-list"
stepSetToList [Set s] = rewriteTo $ FValue $ List (S.toList s)
stepSetToList vs = sortErr (set_to_list (map FValue vs)) "set-to-list not applied to a set"

is_set_empty = applyFuncon "is-set-empty"
is_set_empty_op [Set s] = rewriteTo $ FValue $ tobool (null s)
is_set_empty_op vs = sortErr (is_set_empty (map FValue vs)) "is-set-empty not applied to a set"

set_size = applyFuncon "set-size"
set_size_op [Set s] = rewriteTo $ int_ (S.size s) 
set_size_op vs = sortErr (set_size (map FValue vs)) "set-size not applied to a set"

set_intersect = applyFuncon "set-intersect"
set_intersect_op [] = rewriteTo $ FValue $ Set S.empty
set_intersect_op vs
    | all isSet_ vs = rewriteTo $ FValue $ Set (foldr1 S.intersection (map toSet vs))
    | otherwise = sortErr (set_intersect (map FValue vs)) "set-intersect not applied to sets"
    where   isSet_ (Set _) = True
            isSet_ _       = False
            toSet (Set s)  = s
            toSet _        = error "set-intersect toSet"

set_difference = applyFuncon "set-difference"
set_difference_op [Set s1, Set s2] = rewriteTo $ FValue $ Set (s1 `S.difference` s2)
set_difference_op vs = sortErr (set_difference (map FValue vs)) 
                            "set-difference not applied to two sets"

some_element = applyFuncon "some-element"
stepSome_Element [Set s] | not (null s) = rewriteTo $ FValue $ S.findMax s
stepSome_Element vs = sortErr (some_element (map FValue vs)) "some-element not applied to a set"

is_subset = applyFuncon "is-subset"
stepIs_Subset [Set s1, Set s2] = rewriteTo $ FValue $ tobool (s1 `S.isSubsetOf` s2)
stepIs_Subset vs = sortErr (is_subset (map FValue vs)) "is-subset not applied to two sets"

stepSet :: [Values] -> Rewrite Rewritten 
stepSet vs = rewriteTo $ FValue $ Set (S.fromList vs)

stepIsInSet [e,Set s] = rewriteTo $ FValue $ tobool (e `S.member` s) 

stepIsInSet vs = sortErr (applyFuncon "is-in-set" (map FValue vs)) "sort check: is-in-set(_,_)"

set_unite = applyFuncon "set-unite"
set_unite_op :: [Values] -> Rewrite Rewritten 
set_unite_op vs | all isSet_ vs = rewriteTo $ FValue $ Set $ S.unions $ map unSet vs
                | otherwise = sortErr (set_unite (map FValue vs)) "set-unite not applied to sets"
    where   isSet_ (Set s) = True
            isSet_ _       = False
            unSet (Set s) = s
            unSet _       = error "set-unite not applied to sets only"


set_insert = applyFuncon "set-insert"
stepSet_Insert [e,Set s] = rewriteTo $ FValue $ Set (e `S.insert` s)
stepSet_Insert vs        = sortErr (set_insert (map FValue vs)) "sort check: set-insert(_,_)"

list_to_set = applyFuncon "list-to-set"
stepList_To_Set [List l]        = rewriteTo $ FValue $ Set $ S.fromList l
stepList_To_Set vs              = sortErr (list_to_set (map FValue vs)) "list-to-set not applied to a list"