"Committed_by_peb"

1 files changed, 74 insertions, 3 deletions

diff --git a/src/GF/Formalism/Utilities.hs b/src/GF/Formalism/Utilities.hs
index fabb708d1..3948980e1 100644
--- a/src/GF/Formalism/Utilities.hs
+++ b/src/GF/Formalism/Utilities.hs
@@ -4,9 +4,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:22:14 $ 
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.5 $
+-- > CVS $Date: 2005/05/13 12:40:19 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.6 $
 --
 -- Basic type declarations and functions for grammar formalisms
 -----------------------------------------------------------------------------
@@ -238,6 +238,69 @@ forest2trees (FNode n forests) = map (TNode n) $ forests >>= mapM forest2trees
 forest2trees (FMeta) = [TMeta]
 
 
+----------------------------------------------------------------------
+-- * profiles
+
+-- | Pairing a rule name with a profile
+data NameProfile a = Name a [Profile (SyntaxForest a)]
+		     deriving (Eq, Ord, Show)
+
+name2fun :: NameProfile a -> a
+name2fun (Name fun _) = fun
+
+-- | A profile is a simple representation of a function on a number of arguments.
+-- We only use lists of profiles
+data Profile a = Unify [Int] -- ^ The Int's are the argument positions.
+			     -- 'Unify []' will become a metavariable,
+			     -- 'Unify [a,b]' means that the arguments are equal,
+	       | Constant a
+		 deriving (Eq, Ord, Show)
+
+instance Functor Profile where
+    fmap f (Constant a) = Constant (f a)
+    fmap f (Unify xs)   = Unify xs
+
+-- | a function name where the profile does not contain arguments 
+-- (i.e. denoting a constant, not a function)
+constantNameToForest :: NameProfile a -> SyntaxForest a
+constantNameToForest name@(Name fun profile) = FNode fun [map unConstant profile] 
+    where unConstant (Constant a) = a
+	  unConstant (Unify [])   = FMeta
+	  unConstant _ = error $ "constantNameToForest: the profile should not contain arguments"
+
+-- | profile application; we need some way of unifying a list of arguments
+applyProfile :: ([b] -> a) -> [Profile a] -> [b] -> [a]
+applyProfile unify profile args = map apply profile
+    where apply (Unify xs)  = unify $ map (args !!) xs
+	  apply (Constant a) = a
+
+-- | monadic profile application
+applyProfileM :: Monad m => ([b] -> m a) -> [Profile a] -> [b] -> m [a]
+applyProfileM unify profile args = mapM apply profile
+    where apply (Unify xs)  = unify $ map (args !!) xs
+	  apply (Constant a) = return a
+
+-- | profile composition: 
+-- 
+-- >   applyProfile u z (ps `composeProfiles` qs) args
+-- >      ==
+-- >   applyProfile u z ps (applyProfile u z qs args)
+--
+-- compare with function composition
+--
+-- >   (p . q) arg
+-- >      ==
+-- >   p (q arg)
+--
+-- Note that composing an 'Constant' with two or more arguments returns an error
+-- (since 'Unify' can only take arguments) -- this might change in the future, if there is a need.
+composeProfiles :: [Profile a] -> [Profile a] -> [Profile a]
+composeProfiles ps qs = map compose ps
+    where compose (Unify [x]) = qs !! x
+	  compose (Unify xs)  = Unify [ y | x <- xs, let Unify ys = qs !! x, y <- ys ]
+	  compose constant    = constant
+
+
 
 ------------------------------------------------------------
 -- pretty-printing
@@ -275,4 +338,12 @@ instance (Print s) => Print (SyntaxForest s) where
     prt (FMeta) = "?"
     prtList = prtAfter "\n"
 
+instance Print a => Print (Profile a) where
+    prt (Unify [])   = "?"
+    prt (Unify args) = prtSep "=" args
+    prt (Constant a) = prt a
+
+instance Print a => Print (NameProfile a) where
+    prt (Name fun profile) = prt fun ++ prt profile
+