{-# LANGUAGE GADTs, Rank2Types #-}
{-# OPTIONS_GHC -Wall #-}
-------------------------------------------------------------------------------
{- |
Module : Language.Type.Rewrite
Description : Strategic rewriting combinators for the type representation.
Copyright : (c) Paulo Silva
License : LGPL
Maintainer : paufil@di.uminho.pt
Stability : experimental
Portability : portable
-}
-------------------------------------------------------------------------------
module Language.Type.Rewrite (
Rule,
View(View),
showType,
view2Box,
nop,
fail,
seqRules,
(>>>),
(|||),
many,
many1,
try,
once,
everywhere,
everywhere',
innermost,
all
) where
import Control.Monad hiding (fail)
import Data.Existential
import Language.Type.Syntax
import Prelude hiding (all,fail)
-------------------------------------------------------------------------------
data View a where
View :: Type b -> View (Type a)
instance Show (View a) where
show (View b) = "View: " ++ show b
-------------------------------------------------------------------------------
showType :: View a -> String
showType (View b) = show b
-------------------------------------------------------------------------------
view2Box :: View (Type b) -> TypeBox
view2Box (View t) = Hide t
-------------------------------------------------------------------------------
type Rule = forall a . forall m . MonadPlus m => Type a -> m (View (Type a))
-------------------------------------------------------------------------------
nop :: Rule
nop = return . View
-------------------------------------------------------------------------------
fail :: Rule
fail _ = mzero
-------------------------------------------------------------------------------
seqRules :: [Rule] -> Rule
seqRules [] = fail
seqRules (x:xs) = x ||| seqRules xs
-------------------------------------------------------------------------------
(>>>) :: Rule -> Rule -> Rule
(f >>> g) a = do
View b <- f a
View c <- g b
return $ View c
-------------------------------------------------------------------------------
(|||) :: Rule -> Rule -> Rule
(f ||| g) x = f x `mplus` g x
-------------------------------------------------------------------------------
many :: Rule -> Rule
many r = (r >>> many r) ||| nop
-------------------------------------------------------------------------------
many1 :: Rule -> Rule
many1 r = r >>> many r
-------------------------------------------------------------------------------
try :: Rule -> Rule
try r = r ||| nop
-------------------------------------------------------------------------------
once :: Rule -> Rule
once r x@(TVar _) = r x
once r One = r One
once r Bool = r Bool
once r Char = r Char
once r String = r String
once r Int = r Int
once r Float = r Float
once r (Prod a b) =
r (Prod a b) `mplus`
(do View c <- once r a
return $ View (Prod c b)) `mplus`
(do View c <- once r b
return $ View (Prod a c))
once r (Either a b) =
r (Either a b) `mplus`
(do View c <- once r a
return $ View (Either c b)) `mplus`
(do View c <- once r b
return $ View (Prod a c))
once r (Maybe a) =
r (Maybe a) `mplus`
(do View c <- once r a
return $ View (Maybe c))
once r (List a) =
r (List a) `mplus`
(do View c <- once r a
return $ View (List c))
once r (Set a) =
r (Set a) `mplus`
(do View c <- once r a
return $ View (Set c))
once r (Map a b) =
r (Map a b) `mplus`
(do View c <- once r a
return $ View (Map c b)) `mplus`
(do View c <- once r b
return $ View (Map a c))
once r (Fun a b) =
r (Fun a b) `mplus`
(do View c <- once r a
return $ View (Fun c b)) `mplus`
(do View c <- once r b
return $ View (Fun a c))
once r (Rel a b) =
r (Rel a b) `mplus`
(do View c <- once r a
return $ View (Rel c b)) `mplus`
(do View c <- once r b
return $ View (Rel a c))
once r (Ord a) =
r (Ord a) `mplus`
(do View c <- once r a
return $ View (Ord c))
once r (GC a b) =
r (GC a b) `mplus`
(do View c <- once r a
return $ View (GC c b)) `mplus`
(do View c <- once r b
return $ View (GC a c))
-------------------------------------------------------------------------------
everywhere :: Rule -> Rule
everywhere r = r >>> all (everywhere r)
-------------------------------------------------------------------------------
everywhere' :: Rule -> Rule
everywhere' r = all (everywhere' r) >>> r
-------------------------------------------------------------------------------
innermost :: Rule -> Rule
innermost r = all (innermost r) >>> try (r >>> innermost r)
-------------------------------------------------------------------------------
all :: Rule -> Rule
all r x@(TVar _) = r x
all r One = r One
all r Bool = r Bool
all r Char = r Char
all r String = r String
all r Int = r Int
all r Float = r Float
all r (Prod a b) = do
View a' <- r a
View b' <- r b
return $ View (Prod a' b')
all r (Either a b) = do
View a' <- r a
View b' <- r b
return $ View (Either a' b')
all r (Maybe a) = do
View a' <- r a
return $ View (Maybe a')
all r (List a) = do
View a' <- r a
return $ View (List a')
all r (Set a) = do
View a' <- r a
return $ View (Set a')
all r (Map a b) = do
View a' <- r a
View b' <- r b
return $ View (Map a' b')
all r (Fun a b) = do
View a' <- r a
View b' <- r b
return $ View (Fun a' b')
all r (Rel a b) = do
View a' <- r a
View b' <- r b
return $ View (Rel a' b')
all r (Ord a) = do
View a' <- r a
return $ View (Ord a')
all r (GC a b) = do
View a' <- r a
View b' <- r b
return $ View (GC a' b')
-------------------------------------------------------------------------------
|
