Maps.hs

{-# LANGUAGE OverloadedStrings #-}

module Funcons.Operations.Maps where

import Funcons.Operations.Booleans
import Funcons.Operations.Internal
import Funcons.Operations.Sets
import qualified Data.Map as M
import qualified Data.Set as S 

library :: (HasValues t, Ord t) => Library t
library = libFromList [
    ("map-empty", NullaryExpr map_empty)
  , ("map-singleton", BinaryExpr map_singleton)
  , ("is-map-empty", UnaryExpr is_map_empty)
  , ("map-insert", TernaryExpr map_insert)
  , ("map-lookup", BinaryExpr map_lookup)
  , ("lookup", BinaryExpr map_lookup)
  , ("map-domain", UnaryExpr domain)
  , ("domain", UnaryExpr domain)
  , ("map-delete", BinaryExpr map_delete)
  , ("is-in-domain", BinaryExpr is_in_domain)
  , ("map-unite", NaryExpr map_unite)
  , ("map-override", BinaryExpr map_override)
  , ("maps", BinaryExpr maps)
  , ("map", NaryExpr map_)
  , ("map-elements", UnaryExpr map_elements)
  , ("map-points", UnaryExpr map_points)
  ]

map_ :: (Ord t, HasValues t) => [OpExpr t] -> OpExpr t
map_ = vNaryOp "map" (Normal . inject . Map . M.fromList . mkPairs)

mkPairs :: [a] -> [(a,a)]
mkPairs []        = []
mkPairs [x]       = []
mkPairs (x:y:ys)  = (x,y) : mkPairs ys

maps_ :: HasValues t => [OpExpr t] -> OpExpr t
maps_ = binaryOp maps
maps :: HasValues t => OpExpr t -> OpExpr t -> OpExpr t
maps = vBinaryOp "maps" op
  where op (ComputationType (Type t1)) (ComputationType (Type t2)) = Normal $ injectT (Maps t1 t2)
        op _ _ = SortErr "maps not applied to two types"

map_empty_ :: HasValues t => [OpExpr t] -> OpExpr t 
map_empty_ = nullaryOp map_empty
map_empty :: HasValues t => OpExpr t 
map_empty = NullaryOp "map-empty" (Normal $ inject (Map M.empty))

map_singleton_ :: (HasValues t,Ord t) => [OpExpr t] -> OpExpr t
map_singleton_ = binaryOp map_singleton
map_singleton :: (HasValues t, Ord t) => OpExpr t -> OpExpr t -> OpExpr t 
map_singleton k v = RewritesTo "map-insert" (map_insert map_empty k v) [k,v]

is_map_empty_ :: HasValues t => [OpExpr t] -> OpExpr t
is_map_empty_ = unaryOp is_map_empty
is_map_empty :: HasValues t => OpExpr t -> OpExpr t 
is_map_empty = vUnaryOp "is-map-empty" op 
  where op (Map m)  = Normal $ inject $ tobool (null m)
        op _        = SortErr "is-map-empty(M) not applied to a map"

map_insert_ :: (HasValues t, Ord t) => [OpExpr t] -> OpExpr t
map_insert_ = ternaryOp map_insert 
map_insert :: (HasValues t, Ord t) => OpExpr t -> OpExpr t -> OpExpr t -> OpExpr t
map_insert = vTernaryOp "map-insert" op
  where op xv k v = case xv of 
              Map m -> Normal $ inject $ Map (M.insert k v m)
              _     -> SortErr "map-insert(M,K,V) not applied to a map (first argument)"

map_lookup_ :: (HasValues t, Ord t) => [OpExpr t] -> OpExpr t
map_lookup_ = binaryOp map_lookup
map_lookup :: (HasValues t, Ord t) => OpExpr t -> OpExpr t -> OpExpr t
map_lookup = vBinaryOp "map-lookup" op
  where op xv k = case xv of 
                    Map m -> case M.lookup k m of 
                        Nothing -> DomErr "key not in domain"
                        Just v  -> Normal $ inject v
                    _ -> SortErr "map-lookup(M,V) not applied to a map and a value"

map_delete_ :: (HasValues t, Ord t) => [OpExpr t] -> OpExpr t
map_delete_ = binaryOp map_delete
map_delete :: (HasValues t, Ord t) => OpExpr t -> OpExpr t -> OpExpr t
map_delete = vBinaryOp "map-delete" op
  where op (Map m) (Set s) = Normal $ inject $ Map (foldr M.delete m s)
        op _ _ = SortErr "map-delete(M,S) not applied to a map and a set"

is_in_domain_ :: (Ord t, HasValues t) => [OpExpr t] -> OpExpr t 
is_in_domain_ = binaryOp is_in_domain
is_in_domain :: (Ord t, HasValues t) => OpExpr t -> OpExpr t -> OpExpr t 
is_in_domain x y = RewritesTo "is-in-domain" (is_in_set x (domain y)) [x,y] 

domain_ :: (HasValues t, Ord t) => [OpExpr t] -> OpExpr t
domain_ = unaryOp domain
domain :: (HasValues t, Ord t) => OpExpr t -> OpExpr t
domain = vUnaryOp "domain" op
  where op (Map m)  = Normal $ inject $ Set $ S.fromList $ M.keys m
        op _        = SortErr "domain(M) not applied to a map"

map_override_ :: (HasValues t, Ord t) => [OpExpr t] -> OpExpr t
map_override_ = binaryOp map_override
map_override :: (HasValues t, Ord t) => OpExpr t -> OpExpr t -> OpExpr t
map_override = vBinaryOp "map-override" op
  where op (Map m1) (Map m2) = Normal $ inject $ Map (M.union m1 m2)
        op _ _ = SortErr "map-override(M,M) not applied tOpExpr two maps"

map_unite_ :: (HasValues t, Ord t) => [OpExpr t] -> OpExpr t
map_unite_ = map_unite 
map_unite :: (HasValues t, Ord t) => [OpExpr t] -> OpExpr t
map_unite = vNaryOp "map-unite" op
  where op args 
          | all isMap args =
              let maps = map toMap args
                  domains = map (M.keysSet) maps
              in if all (null . uncurry S.intersection) (allDomainPairs domains)
                  then Normal $ inject $ Map $ M.unions maps
                  else DomErr "union with domain intersection"
          | otherwise     = SortErr "map-unite(M1,...,Mn) not applied to maps"
          where isMap (Map _) = True
                isMap _       = False
                toMap (Map m) = m
                toMap _       = error "map_unite"

allDomainPairs :: [a] -> [(a,a)] 
allDomainPairs (x:xs) = [ (x,y)  | y <- xs ] ++ allDomainPairs xs
allDomainPairs [] = []

map_elements_ :: (Ord t, HasValues t) => [OpExpr t] -> OpExpr t
map_elements_ = unaryOp map_elements
map_elements :: (Ord t, HasValues t) => OpExpr t -> OpExpr t
map_elements = vUnaryOp "map-elements" op
  where op (Map m) = Normal $ inject $ ADTVal "list" (map inject $ M.foldrWithKey combine [] m)
          where combine k v ls = k:v:ls
        op _ = SortErr "map-elements not applied to a map"

map_points_ :: (Ord t, HasValues t) => [OpExpr t] -> OpExpr t
map_points_ = unaryOp map_points
map_points :: (Ord t, HasValues t) => OpExpr t -> OpExpr t
map_points = vUnaryOp "map-points" op
  where op (Map m) = Normal $ inject $ ADTVal "list" (map inject $ M.foldrWithKey combine [] m)
          where combine k v ls = ADTVal "tuple" [inject k, inject v]:ls
        op _ = SortErr "map-points not applied to a map"