Environment.hs

{-# LANGUAGE ExistentialQuantification #-}
-----------------------------------------------------------------------------
-- Copyright 2016, Ideas project team. This file is distributed under the
-- terms of the Apache License 2.0. For more information, see the files
-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer  :  bastiaan.heeren@ou.nl
-- Stability   :  provisional
-- Portability :  portable (depends on ghc)
--
-- References, bindings, and heterogenous environments
--
-----------------------------------------------------------------------------

module Ideas.Common.Environment
   ( -- * Reference
     Ref, Reference(..), mapRef
     -- * Binding
   , Binding, makeBinding
   , fromBinding, showValue, getTermValue
     -- * Heterogeneous environment
   , Environment, makeEnvironment, singleBinding
   , HasEnvironment(..), HasRefs(..)
   , bindings, noBindings, (?)
   ) where

import Control.Monad
import Data.Function
import Data.List
import Ideas.Common.Id
import Ideas.Common.Rewriting.Term
import Ideas.Common.View
import Ideas.Utils.Prelude
import Ideas.Utils.Typeable
import qualified Data.Map as M

-----------------------------------------------------------
-- Reference

-- | A data type for references (without a value)
data Ref a = Ref
   { identifier :: Id                -- Identifier
   , printer    :: a -> String       -- Pretty-printer
   , parser     :: String -> Maybe a -- Parser
   , refView    :: View Term a       -- Conversion to/from term
   , refType    :: IsTypeable a
   }

instance Show (Ref a) where
   show = showId

instance Eq (Ref a) where
   (==) = (==) `on` getId

instance HasId (Ref a) where
   getId = identifier
   changeId f d = d {identifier = f (identifier d)}

instance HasTypeable Ref where
   getTypeable = Just . refType

-- | A type class for types as references
class (IsTerm a, Typeable a, Show a, Read a) => Reference a where
   makeRef     :: IsId n => n -> Ref a
   makeRefList :: IsId n => n -> Ref [a]
   -- default implementation
   makeRef n     = Ref (newId n) show readM termView typeable
   makeRefList n = Ref (newId n) show readM termView typeable

instance Reference Int

instance Reference Term

instance Reference Char where
   makeRefList n = Ref (newId n) id Just variableView typeable

instance Reference ShowString

instance Reference a => Reference [a] where
   makeRef = makeRefList

instance (Reference a, Reference b) => Reference (a, b)

mapRef :: Typeable b => Isomorphism a b -> Ref a -> Ref b
mapRef iso r = r
   { printer = printer r . to iso
   , parser  = fmap (from iso) . parser r
   , refView = refView r >>> toView iso
   , refType = typeable
   }

-----------------------------------------------------------
-- Binding

data Binding = forall a . Binding (Ref a) a

instance Show Binding where
   show a = showId a ++ "=" ++ showValue a

instance Eq Binding where
   (==) = let f (Binding r a) = (getId r, build (refView r) a)
          in (==) `on` f

instance HasId Binding where
   getId (Binding r _ ) = getId r
   changeId f (Binding r a) = Binding (changeId f r) a

makeBinding :: Ref a -> a -> Binding
makeBinding = Binding

fromBinding :: Typeable a => Binding -> Maybe (Ref a, a)
fromBinding (Binding r a) = liftM2 (,) (gcastFrom r r) (castFrom r a)

showValue :: Binding -> String
showValue (Binding r a) = printer r a

getTermValue :: Binding -> Term
getTermValue (Binding r a) = build (refView r) a

-----------------------------------------------------------
-- Heterogeneous environment

newtype Environment = Env { envMap :: M.Map Id Binding }
   deriving Eq

instance Show Environment where
   show = intercalate ", " . map show . bindings

instance Monoid Environment where
   mempty = Env mempty
   mappend a b = Env (envMap a `mappend` envMap b) -- left has presedence

instance HasRefs Environment where
   allRefs env = [ Some ref | Binding ref _ <- bindings env ]

makeEnvironment :: [Binding] -> Environment
makeEnvironment xs = Env $ M.fromList [ (getId a, a) | a <- xs ]

singleBinding :: Ref a -> a -> Environment
singleBinding r = makeEnvironment . return . Binding r

class HasEnvironment env where
   environment    :: env -> Environment
   setEnvironment :: Environment -> env -> env
   deleteRef      :: Ref a -> env -> env
   insertRef      :: Ref a -> a -> env -> env
   changeRef      :: Ref a -> (a -> a) -> env -> env
   -- default definitions
   deleteRef a = changeEnv (Env . M.delete (getId a) . envMap)
   insertRef r =
      let f b = Env . M.insert (getId b) b . envMap
      in changeEnv . f . Binding r
   changeRef r f env  =
      maybe id (insertRef r . f) (r ? env) env

-- local helper
changeEnv :: HasEnvironment env => (Environment -> Environment) -> env -> env
changeEnv f env = setEnvironment (f (environment env)) env

class HasRefs a where
   getRefs   :: a -> [Some Ref]
   allRefs   :: a -> [Some Ref] -- with duplicates
   getRefIds :: a -> [Id]
   -- default implementation
   getRefIds a = [ getId r | Some r <- getRefs a]
   getRefs = sortBy cmp . nubBy eq . allRefs
    where
      cmp :: Some Ref -> Some Ref -> Ordering
      cmp (Some x) (Some y) = compareId (getId x) (getId y)
      eq a b = cmp a b == EQ

instance HasEnvironment Environment where
   environment    = id
   setEnvironment = const

bindings :: HasEnvironment env => env -> [Binding]
bindings = sortBy compareId . M.elems . envMap . environment

noBindings :: HasEnvironment env => env -> Bool
noBindings = M.null . envMap . environment

(?) :: HasEnvironment env => Ref a -> env -> Maybe a
ref ? env = do
   let m = envMap (environment env)
   Binding r a <- M.lookup (getId ref) m
   msum [ castBetween r ref a                  -- typed value
        , castFrom r a >>= parser ref          -- value as string
        , castFrom r a >>= match (refView ref) -- value as term
        ]