Maps.hs

{-# LANGUAGE OverloadedStrings #-}

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

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

import qualified Data.Set as S
import qualified Data.Map as M

library = libFromList [
        ("map-empty", NullaryFuncon (rewritten (Map M.empty)))
    ,   ("lookup", ValueOp lookup_op)
    ,   ("domain", ValueOp stepDomain)
    ,   ("map-override", ValueOp stepMapOverride)
    ,   ("map-unite", ValueOp unite_maps)
    ,   ("map-delete", ValueOp stepMapDelete)
    ,   ("map-to-list", ValueOp stepMapToList)
    ,   ("is-map-empty", ValueOp stepIsMapEmpty)
    ,   ("list-to-map", ValueOp list_to_map_op)
    ,   ("set-to-map", ValueOp set_to_map_op)
    ]

is_map_empty = applyFuncon "is-map-empty"
stepIsMapEmpty [Map m] = rewriteTo $ FValue $ tobool (null m)
stepIsMapEmpty vs = sortErr (is_map_empty (fvalues vs)) "is-map-empty not applied to a map"

map_to_list = applyFuncon "map-to-list"
stepMapToList [Map m] = rewriteTo $ FValue $ List $ map toTup $ M.assocs m
    where toTup (k,v) = NonEmptyTuple k v []
stepMapToList vs = sortErr (map_to_list (fvalues vs)) "map-to-list not applied to a map"

map_delete = applyFuncon "map-delete"
stepMapDelete [Map m, Set s] = rewriteTo $ FValue $ Map (foldr M.delete m s)
stepMapDelete vs = sortErr (map_delete (fvalues vs))
                        "map-delete not applied to a map and set of values"

-- | 
-- Computes the union over a sequence of maps.
-- If the maps do not have disjoint domains a failure signal is raised.
map_unite_ = FApp "map-unite" . FTuple

unite_maps vs
  | not (all isMap vs) = sortErr (map_unite_ (fvalues vs)) 
                            "map-unite not applied to a sequence of maps"
  | otherwise = 
        let maps = map toMap vs
            domains = map (M.keysSet) maps
         in if S.null (foldr S.intersection S.empty domains)
                then rewriteTo $ FValue $ Map $ M.unions maps
                else partialOp (map_unite_ (fvalues vs)) 
                        "map-unite not applied to maps with disjoint domains"
 where  toMap (Map m) = m
        toMap _       = error "unite-maps, toMap"
        isMap (Map m) = True
        isMap _       = False

lookup_ = applyFuncon "lookup"

lookup_op v@[k, Map m] = case M.lookup k m of
                            Nothing -> partialOp (lookup_ (fvalues v)) "failed to lookup"
                            Just v  -> rewriteTo $ FValue v
lookup_op vs = sortErr (lookup_ (fvalues vs)) "lookup not given a key and a map"

-- | 
-- Computes the left-biased union over two maps.
map_override_ :: [Funcons] -> Funcons
map_override_ = applyFuncon "map-override"
stepMapOverride [x,y]  = rewriteTo =<< map_override_op x y
    where
    map_override_op :: Values -> Values -> Rewrite Funcons
    map_override_op (Map m1) (Map m2) = return (FValue $ Map $ M.union m1 m2)
    map_override_op v1 v2 = sortErr (applyFuncon "map-override" [FValue v1, FValue v2]) "map-override not applied to maps"
stepMapOverride vs = sortErr (applyFuncon "map-override" (fvalues vs)) "map-override(M1,M2)"

stepDomain m  = rewriteTo =<< domain m
    where
    domain :: [Values] -> Rewrite Funcons
    domain [Map m] = return $ FValue $ Set $ S.fromList $ M.keys m
    domain vs = sortErr (applyFuncon "domain" (fvalues vs)) "domain not given a map"

set_to_map = applyFuncon "set-to-map"
set_to_map_op :: [Values] -> Rewrite Rewritten
set_to_map_op [Set vs]
    | all isPair_ vs = rewriteTo $ FValue $ Map $ M.fromList $ map unPair $ S.toList vs
 where isPair_ (NonEmptyTuple _ _ []) = True
       isPair_ _ = False
       unPair (NonEmptyTuple k v []) = (k,v)
       unPair _ = error "set-to-map not applied to a set of key-value pairs"
set_to_map_op vs = sortErr (set_to_map (fvalues vs))
    "set-to-map not applied to a set of key-value pairs"

list_to_map = applyFuncon "list-to-map"
list_to_map_op :: [Values] -> Rewrite Rewritten
list_to_map_op [List vs]
    | all isPair_ vs = rewriteTo $ FValue $ Map $ M.fromList $ map unPair $ vs
 where isPair_ (NonEmptyTuple _ _ []) = True
       isPair_ _ = False
       unPair (NonEmptyTuple k v []) = (k,v)
       unPair _ = error "set-to-map not applied to a set of key-value pairs"
list_to_map_op vs = sortErr (list_to_map (fvalues vs))
    "list-to-map not applied a lit of key-value pairs"