alms-0.6.0: src/Value.hs
-- | The representation and embedding of values
module Value (
-- * Value and function representation
Valuable(..), FunName(..), Value(..),
funNameDocs,
-- ** Common values
vaInt, vaUnit,
-- ** Some pre-defined value types
Vinj(..), VExn(..),
-- *** Exception IDs
ExnId(..),
-- ** Records
VRecord(..),
-- * Utilities for algebraic data types
enumTypeDecl,
vinjData, vprjDataM
) where
import qualified Data.List as List
import qualified Data.Char as Char
import Data.Generics
import Util
import AST (Type, Renamed, Id(..), Uid, ConId, uidToLid)
import Syntax.Ppr (Doc, text, Ppr(..), hang, sep, char, (<>), (<+>),
prec, prec1, ppr1, atPrec, precCom, precApp)
import qualified Syntax.Ppr as Ppr
import qualified Control.Exception as Exn
import qualified Control.Monad as C.M
import Prelude ()
import Foreign.C.Types (CInt)
import Data.Word (Word32, Word16)
-- | The kind of identifiers used
type R = Renamed
-- | The name of a function
data FunName
-- | An anonymous function, whose name is overwritten by binding
= FNAnonymous [Doc]
-- | An already-named function
| FNNamed Doc
funNameDocs :: FunName -> [Doc]
funNameDocs (FNAnonymous docs) = docs
funNameDocs (FNNamed doc) = [doc]
-- | Class for Haskell values that can be injected as object-language
-- values
--
-- All methods have reasonable (not very useful) defaults.
class Typeable a => Valuable a where
-- | Equality (default returns 'False')
veq :: a -> a -> Bool
veq _ _ = False
-- | Dynamic equality: attempts to coerce two 'Valuable's
-- to the same Haskell type and then compare them
veqDyn :: Valuable b => a -> b -> Bool
veqDyn a b = maybe False (veq a) (vcast b)
-- | Pretty-print a value at current precedence
vppr :: a -> Doc
vppr _ = text "#<->"
-- | Inject a Haskell value into the 'Value' type
vinj :: a -> Value
vinj a = case cast a of
Just v -> v
Nothing -> VaDyn a
-- | Project a Haskell value from the 'Value' type
vprjM :: Monad m => Value -> m a
vprjM = vcast
-- | Project a Haskell value from the 'Value' type, or fail
vprj :: Value -> a
vprj = maybe (error "BUG! vprj: coercion error") id . vprjM
-- | Pretty-print a list of values. (This is the same hack used
-- by 'Show' for printing 'String's differently than other
-- lists.)
vpprList :: [a] -> Doc
vpprList =
Ppr.brackets . atPrec 0 . Ppr.fsep . Ppr.punctuate Ppr.comma . map vppr
-- | Inject a list. As with the above, this lets us special-case
-- lists at some types (e.g. we inject Haskell 'String' as object
-- language @string@ rather than @char list@)
vinjList :: [a] -> Value
vinjList [] = VaCon (ident "[]") Nothing
vinjList (x:xs) = VaCon (ident "::") (Just (vinj (x, xs)))
-- | Project a list. (Same deal.)
vprjListM :: Monad m => Value -> m [a]
vprjListM (VaCon (idName -> "[]") Nothing) = return []
vprjListM (VaCon (idName -> "::") (Just v)) = do
(x, xs) <- vprjM v
return (x:xs)
vprjListM _ = fail "vprjM: not a list"
-- | Cast from one 'Typeable' to another, potentially unwrapping
-- dynamic value constructors.
vcast :: (Typeable a, Typeable b, Monad m) => a -> m b
vcast a = case cast a of
Just r -> return r
Nothing -> case cast a of
Just (VaDyn r) -> vcast r
_ -> fail "BUG! vcast: coercion error"
-- | The representation of a value.
--
-- We have special cases for the three classes of values that
-- have special meaning in the dynamics, and push all other Haskell
-- types into a catch-all case.
data Value
-- | A function
= VaFun FunName (Value -> IO Value)
-- | A datacon, potentially applied
| VaCon (ConId R) (Maybe Value)
-- | An open variant injection or embedding. The 'Int' gives the
-- number of embeddings of the label
| VaLab Int (Uid R) Value
-- | Any other embeddable Haskell type
| forall a. Valuable a => VaDyn a
deriving Typeable
-- | Construct an @int@ value
vaInt :: Integer -> Value
vaInt = vinj
-- | The @unit@ value
vaUnit :: Value
vaUnit = vinj ()
-- Ppr instances
instance Ppr FunName where
pprPrec _ fn = hang (text "#<fn") 4 $
sep (funNameDocs fn) <> char '>'
instance Ppr Value where
ppr = vppr
pprList = vpprList
instance Eq Value where
(==) = veq
instance Show Value where
showsPrec p v = shows (pprPrec p v)
instance Valuable a => Valuable [a] where
veq a b = length a == length b && all2 veq a b
vppr = vpprList
vinj = vinjList
vprjM = vprjListM
instance Valuable Int where
veq = (==)
vppr = ppr
vinj = vinj . toInteger
vprjM v = vprjM v >>= \z -> return (fromIntegral (z :: Integer))
instance Valuable Word16 where
veq = (==)
vppr = vppr . toInteger
vinj = vinj . toInteger
vprjM v = vprjM v >>= \z -> return (fromIntegral (z :: Integer))
instance Valuable Word32 where
veq = (==)
vppr = vppr . toInteger
vinj = vinj . toInteger
vprjM v = vprjM v >>= \z -> return (fromIntegral (z :: Integer))
instance Valuable CInt where
veq = (==)
vppr = vppr . toInteger
vinj = vinj . toInteger
vprjM v = vprjM v >>= \z -> return (fromIntegral (z :: Integer))
instance Valuable Integer where
veq = (==)
vppr = ppr
instance Valuable Double where
veq = (==)
vppr = ppr
instance Valuable () where
veq = (==)
vinj () = VaCon (ident "()") Nothing
vprjM (VaCon (idName -> "()") _) = return ()
vprjM _ = fail "vprjM: not a unit"
instance Valuable Bool where
veq = (==)
vinj True = VaCon (ident "true") Nothing
vinj False = VaCon (ident "false") Nothing
vprjM (VaCon (idName -> "true") _) = return True
vprjM (VaCon (idName -> "false") _) = return False
vprjM _ = fail "vprjM: not a bool"
instance Valuable Value where
vinj v = v
veq (VaCon c v) (VaCon d w) = c == d && v == w
veq (VaLab n c v) (VaLab m d w)
= n == m && c == d && v == w
veq (VaDyn a) b = veqDyn a b
veq _ _ = False
vppr v | Just vs ← vprjM v = vppr (vs ∷ [Value])
vppr (VaFun n _) = ppr n
vppr (VaCon c Nothing) = ppr c
vppr (VaCon c (Just v)) = prec precApp $
ppr c <+> ppr1 v
vppr (VaLab 0 c v)
| v == vinj () = char '`' <> ppr c
| otherwise = prec precApp $
char '`' <> ppr c <+> ppr1 v
vppr (VaLab z c v) = prec precApp $
char '#' <> ppr c <+>
ppr1 (VaLab (z - 1) c v)
vppr (VaDyn v) = vppr v
-- for value debugging:
{-
vpprPrec p (VaCon c Nothing) = char '[' <> pprPrec p c <> char ']'
vpprPrec p (VaCon c (Just v)) = parensIf (p > precApp) $
char '[' <> pprPrec precApp c <+>
vpprPrec (precApp + 1) v <> char ']'
vpprPrec p (VaDyn v) = char '{' <> vpprPrec p v <> char '}'
-}
instance Valuable Char where
veq = (==)
vppr = text . show
vpprList = text . show
vinjList = VaDyn
vprjListM = vcast
instance (Valuable a, Valuable b) => Valuable (a, b) where
veq (a, b) (a', b') = veq a a' && veq b b'
vppr (a, b) = prec precCom $
sep [vppr a <> char ',', prec1 (vppr b)]
vinj (a, b) = VaDyn (vinj a, vinj b)
vprjM v = case vcast v of
Just (a, b) -> do
a' <- vprjM a
b' <- vprjM b
return (a', b')
Nothing -> fail "vprjM: not a pair"
instance (Valuable a, Valuable b) => Valuable (Either a b) where
veq (Left a) (Left a') = veq a a'
veq (Right b) (Right b') = veq b b'
veq (Left _) (Right _) = False
veq (Right _) (Left _) = False
vinj (Left v) = VaCon (ident "Left") (Just (vinj v))
vinj (Right v) = VaCon (ident "Right") (Just (vinj v))
vprjM (VaCon (idName -> "Left") (Just v)) = liftM Left (vprjM v)
vprjM (VaCon (idName -> "Right") (Just v)) = liftM Right (vprjM v)
vprjM _ = fail "vprjM: not a sum"
instance Valuable a => Valuable (Maybe a) where
veq (Just a) (Just a') = veq a a'
veq Nothing Nothing = True
veq (Just _) Nothing = False
veq Nothing (Just _) = False
vinj (Just v) = VaCon (ident "Some") (Just (vinj v))
vinj Nothing = VaCon (ident "None") Nothing
vprjM (VaCon (idName -> "Some") (Just v)) = liftM Just (vprjM v)
vprjM (VaCon (idName -> "None") Nothing) = return Nothing
vprjM _ = fail "vprjM: not an option"
-- | Type for injection of arbitrary Haskell values with
-- minimal functionality
newtype Vinj a = Vinj { unVinj :: a }
deriving (Eq, Typeable, Data)
instance (Eq a, Show a, Data a) => Valuable (Vinj a) where
veq = (==)
vppr = text . show
instance Show a => Show (Vinj a) where
showsPrec p = showsPrec p . unVinj
-- Exceptions
-- | The representation of exceptions
data VExn = VExn {
exnValue :: Value
}
deriving (Typeable, Eq)
instance Valuable VExn where
veq = (==)
vppr = vppr . exnValue
instance Show VExn where
showsPrec p e = (show (atPrec p (vppr e)) ++)
instance Exn.Exception VExn
-- | Exception identity, generated dynamically
data ExnId i = ExnId {
eiName :: ConId i,
eiParam :: Maybe (Type i)
}
deriving (Typeable, Data)
instance Eq (ExnId Renamed) where
ei == ei' = eiName ei == eiName ei'
--
-- Representation of records
--
data VRecord
= AdditiveRecord [(Uid Renamed, (IO Value, Doc))]
| MultiplicativeRecord [(Uid Renamed, Value)]
deriving Typeable
instance Valuable VRecord where
veq (MultiplicativeRecord kvs0) (MultiplicativeRecord kvs0') =
loop (sortFst kvs0) (sortFst kvs0')
where
sortFst = List.sortBy (compare`on`fst)
loop [] [] = True
loop ((k,v):kvs) ((k',v'):kvs') = k == k' && veq v v' && loop kvs kvs'
loop _ _ = False
veq _ _ = False
vppr record =
case record of
AdditiveRecord kvs → finish "{+" ((fst &&& snd . snd) <$> kvs) "+}"
MultiplicativeRecord kvs → finish "{" (second vppr <$> kvs) "}"
where
finish lb [] rb = text lb <> text rb
finish lb kvs rb =
text lb <+> Ppr.fsep (Ppr.punctuate (char ',')
[ ppr (show (uidToLid k)) <+> char '=' <+> ppr v
| (k, v) ← kvs ])
<+> text rb
instance Ppr VRecord where ppr = vppr
instance Show VRecord where showsPrec = Ppr.showFromPpr
-- nasty syb stuff
isString :: Data a => a -> Bool
isString a = typeOf a == typeOf ""
-- | Use SYB to attempt to turn a Haskell data type into an object
-- language type declaration
enumTypeDecl :: Data a => a -> String
enumTypeDecl a =
case dataTypeRep ty of
IntRep -> add "int"
FloatRep -> add "float"
CharRep -> add "char"
NoRep -> name
AlgRep cs
| isString a
-> add "string"
| otherwise
-> add (unwords (List.intersperse " | " (map showConstr cs)))
where
ty = dataTypeOf a
add body = name ++ " = " ++ body
name = case last (splitBy (=='.') (dataTypeName ty)) of
c:cs -> Char.toLower c : cs
_ -> error "(BUG!) bad type name in enumTypeDecl"
newtype CONST a b = CONST { unCONST :: a }
-- | Use SYB to attempt to inject a value of a Haskell data type into
-- an object language value matching the type declaration generated
-- by 'enumTypeDecl'.
vinjData :: Data a => a -> Value
vinjData = generic
`ext1Q` (vinj . map vinjData)
`ext1Q` (vinj . maybe Nothing (Just . vinjData))
`extQ` (vinj :: String -> Value)
`extQ` (vinj :: Value -> Value)
`extQ` (vinj :: Bool -> Value)
`extQ` (vinj :: Char -> Value)
where
generic datum = case constrRep r of
IntConstr v -> vinj v
CharConstr v -> vinj v
FloatConstr v -> vinj (fromRational v :: Double)
AlgConstr _
| Just s <- cast datum
-> vinj (s :: String)
| otherwise -> c (unCONST (gfoldl k z datum))
where
r = toConstr datum
k (CONST Nothing) x = CONST (Just (vinjData x))
k (CONST (Just v)) x = CONST (Just (vinj (v, vinjData x)))
z = const (CONST Nothing)
c f = case (showConstr r, f) of
(s, Just f') | isTuple s
-> f'
_ -> VaCon (ident (showConstr r)) f
-- | The partial inverse of 'vinjData'
vprjDataM :: forall a m. (Data a, Monad m) => Value -> m a
vprjDataM = generic
`ext1RT` (\x -> vprjM x >>= C.M.sequence . liftM vprjDataM)
`ext1RT` (\x -> vprjM x >>= maybe (return Nothing) (liftM return)
. liftM vprjDataM)
`extRT` (vprjM :: Value -> m Int)
`extRT` (vprjM :: Value -> m CInt)
`extRT` (vprjM :: Value -> m Word32)
`extRT` (vprjM :: Value -> m Word16)
`extRT` (vprjM :: Value -> m Integer)
`extRT` (vprjM :: Value -> m String)
`extRT` (vprjM :: Value -> m Double)
`extRT` (vprjM :: Value -> m Value)
`extRT` (vprjM :: Value -> m Bool)
`extRT` (vprjM :: Value -> m Char)
where
generic (VaCon (idName -> u) mfields0) = case readConstr ty u of
Nothing -> fail $
"(BUG) Couldn't find constructor: " ++ u ++
" in " ++ show ty
Just c -> evalStateT (gunfold k z c) mfields0
where
k consmaker = do
mfields <- get
fields <- case mfields of
Just fields -> return fields
Nothing -> fail "(BUG) ran out of fields"
field <- case vprjM fields of
Just (fields', field) -> do
put (Just fields')
return field
Nothing -> do
put Nothing
return fields
make <- consmaker
mrest <- get
field' <- case mrest of
Just rest -> do
put Nothing
return (vinj (rest, field))
Nothing ->
return field
datum <- vprjDataM field'
return (make datum)
z = return
generic v@(VaDyn _) = case dataTypeRep ty of
AlgRep (c:_) | t <- showConstr c, isTuple t
-> generic (VaCon (ident t) (Just v))
IntRep | Just i <- vprjM v,
Just d <- cast (i :: Integer)
-> return d
-- May be broken in 6.12:
FloatRep | Just f <- vprjM v,
Just d <- cast (f :: Double)
-> return d
CharRep | Just c <- vprjM v,
Just d <- cast (c :: Char)
-> return d
-- need special case for string?
_ -> fail $ "(BUG) Can't project (VaDyn) " ++ show v ++
" as datatype: " ++ show ty
generic v = fail $ "(BUG) Can't project " ++ show v ++
" as datatype: " ++ show ty
ty = dataTypeOf (undefined :: a)
isTuple :: String -> Bool
isTuple ('(':',':r) | dropWhile (== ',') r == ")"
= True
isTuple _ = False
newtype RT r m a = RT { unRT :: r -> m a }
extRT :: (Typeable a, Typeable b) =>
(r -> m a) -> (r -> m b) -> r -> m a
m1 `extRT` m2 = unRT (maybe (RT m1) id (gcast (RT m2)))
ext1RT :: (Data d, Typeable1 t) =>
(r -> m d) -> (forall e. Data e => r -> m (t e)) -> r -> m d
m1 `ext1RT` m2 = unRT (maybe (RT m1) id (dataCast1 (RT m2)))
{-
ext2RT :: (Data d, Typeable2 t) =>
(r -> m d) ->
(forall e e'. (Data e, Data e') => r -> m (t e e')) ->
r -> m d
m1 `ext2RT` m2 = unRT (maybe (RT m1) id (dataCast2 (RT m2)))
-}