"Committed_by_peb"

1 files changed, 56 insertions, 63 deletions

diff --git a/src/GF/Formalism/SimpleGFC.hs b/src/GF/Formalism/SimpleGFC.hs
index 78837a975..4091b9fdd 100644
--- a/src/GF/Formalism/SimpleGFC.hs
+++ b/src/GF/Formalism/SimpleGFC.hs
@@ -4,9 +4,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/11 13:52:50 $ 
+-- > CVS $Date: 2005/04/12 10:49:45 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
+-- > CVS $Revision: 1.2 $
 --
 -- Simplistic GFC format
 -----------------------------------------------------------------------------
@@ -23,18 +23,10 @@ import GF.Infra.Print
 
 -- * basic (leaf) types
 
-type Name   = Ident.Ident
-type Cat    = Ident.Ident
 type Constr = AbsGFC.CIdent
 type Var    = Ident.Ident
-type Token  = String
 type Label  = AbsGFC.Label
 
--- ** type coercions etc
-
-constr2name :: Constr -> Name
-constr2name (AbsGFC.CIQ _ name) = name
-
 anyVar :: Var
 anyVar = Ident.wildIdent
 
@@ -42,79 +34,80 @@ anyVar = Ident.wildIdent
 
 -- * simple GFC
 
-type SimpleGrammar = Grammar Decl Name LinType (Maybe Term)
-type SimpleRule    = Rule    Decl Name LinType (Maybe Term)
+type SimpleGrammar c n t = Grammar  (Decl c) n (LinType c t) (Maybe (Term c t))
+type SimpleRule    c n t = Rule     (Decl c) n (LinType c t) (Maybe (Term c t))
 
 -- ** dependent type declarations
 
-data Decl = Var ::: Type
-	    deriving (Eq, Ord, Show)
-data Type = Cat :@ [Atom]
-	    deriving (Eq, Ord, Show)
-data Atom = ACon Constr
-	  | AVar Var
-	    deriving (Eq, Ord, Show)
+data Decl c = Var ::: Type c
+		   deriving (Eq, Ord, Show)
+data Type c = c :@ [Atom]
+		   deriving (Eq, Ord, Show)
+data Atom   = ACon Constr
+	    | AVar Var
+	      deriving (Eq, Ord, Show)
 
-decl2cat :: Decl -> Cat
+decl2cat :: Decl c -> c
 decl2cat (_ ::: (cat :@ _)) = cat
 
 -- ** linearization types and terms
 
-data LinType = RecT [(Label, LinType)]
-	     | TblT LinType LinType
-	     | ConT Constr [Term]
-	     | StrT
-	       deriving (Eq, Ord, Show)
+data LinType c t = RecT [(Label, LinType c t)]
+		 | TblT (LinType c t) (LinType c t)
+		 | ConT Constr [Term c t]
+		 | StrT
+		   deriving (Eq, Ord, Show)
 
-isBaseType :: LinType -> Bool
+isBaseType :: LinType c t -> Bool
 isBaseType (ConT _ _) = True
 isBaseType (StrT) = True
 isBaseType _ = False
 
-data Term = Arg Int Cat Path     -- ^ argument variable, the 'Path' is a path 
-				 -- pointing into the term 
-	  | Constr :^ [Term]     -- ^ constructor
-	  | Rec [(Label, Term)]  -- ^ record
-	  | Term :. Label        -- ^ record projection
-	  | Tbl [(Term, Term)]   -- ^ table of patterns\/terms
-	  | Term :! Term         -- ^ table selection
-	  | Variants [Term]      -- ^ variants
-	  | Term :++ Term        -- ^ concatenation
-	  | Token Token          -- ^ single token
-	  | Empty                -- ^ empty string
-	  | Wildcard             -- ^ wildcard pattern variable
-	  | Var Var              -- ^ bound pattern variable
-
-	    -- Res CIdent        -- resource identifier
-	    -- Int Integer       -- integer
+data Term c t
+    = Arg Int c (Path c t)       -- ^ argument variable, the 'Path' is a path 
+			         -- pointing into the term 
+    | Constr :^ [Term c t]       -- ^ constructor
+    | Rec [(Label, Term c t)]    -- ^ record
+    | Term c t :. Label          -- ^ record projection
+    | Tbl [(Term c t, Term c t)] -- ^ table of patterns\/terms
+    | Term c t :! Term c t       -- ^ table selection
+    | Variants [Term c t]        -- ^ variants
+    | Term c t :++ Term c t      -- ^ concatenation
+    | Token t   -- ^ single token
+    | Empty     -- ^ empty string
+    | Wildcard  -- ^ wildcard pattern variable
+    | Var Var   -- ^ bound pattern variable
+
+     -- Res CIdent        -- ^ resource identifier
+     -- Int Integer       -- ^ integer
 	    deriving (Eq, Ord, Show)
 
 -- ** calculations on terms
 
-(+.) :: Term -> Label -> Term
+(+.) :: Term c t -> Label -> Term c t
 Variants terms +. lbl = variants $ map (+. lbl) terms 
 Rec record +. lbl = maybe err id $ lookup lbl record
-    where err = error $ "(+.), label not in record: " ++ show (Rec record) ++ " +. " ++ show lbl
+    where err = error $ "(+.): label not in record"
 Arg arg cat path +. lbl = Arg arg cat (path ++. lbl)
 term +. lbl = term :. lbl
 
-(+!) :: Term -> Term -> Term
+(+!) :: (Eq c, Eq t) => Term c t -> Term c t -> Term c t
 Variants terms +! pat = variants $ map (+! pat) terms 
 term +! Variants pats = variants $ map (term +!) pats 
 term +! arg@(Arg _ _ _) = term :! arg
 Tbl table +! pat = maybe err id $ lookup pat table
-    where err = error $ "(+!), pattern not in table: " ++ show (Tbl table) ++ " +! " ++ show pat
+    where err = error $ "(+!): pattern not in table"
 Arg arg cat path +! pat = Arg arg cat (path ++! pat)
 term +! pat = term :! pat
 
-(?++) :: Term -> Term -> Term
+(?++) :: Term c t -> Term c t -> Term c t
 Variants terms ?++ term  = variants $ map (?++ term) terms
 term  ?++ Variants terms = variants $ map (term ?++) terms
 Empty ?++ term  = term
 term  ?++ Empty = term
 term1 ?++ term2 = term1 :++ term2
 
-variants :: [Term] -> Term
+variants :: [Term c t] -> Term c t
 variants terms0 = case concatMap flatten terms0 of
 		    [term] -> term
 		    terms  -> Variants terms
@@ -123,7 +116,7 @@ variants terms0 = case concatMap flatten terms0 of
 
 -- ** enumerations
 
-enumerateTerms :: Maybe Term -> LinType -> [Term]
+enumerateTerms :: (Eq c, Eq t) => Maybe (Term c t) -> LinType c t -> [Term c t]
 enumerateTerms arg (StrT) = maybe err return arg
     where err = error "enumeratePatterns: parameter type should not be string"
 enumerateTerms arg (ConT _ terms) = terms
@@ -134,41 +127,41 @@ enumerateTerms arg (TblT ptype ctype)
     = liftM Tbl $ mapM enumCase $ enumeratePatterns ptype
     where enumCase pat = liftM ((,) pat) $ enumerateTerms (fmap (+! pat) arg) ctype
 
-enumeratePatterns :: LinType -> [Term]
+enumeratePatterns :: (Eq c, Eq t) => LinType c t -> [Term c t]
 enumeratePatterns = enumerateTerms Nothing
 
 ----------------------------------------------------------------------
 
 -- * paths of record projections and table selections
 
-newtype Path = Path [Either Label Term] deriving (Eq, Ord, Show)
+newtype Path c t = Path [Either Label (Term c t)] deriving (Eq, Ord, Show)
 
-emptyPath :: Path
+emptyPath :: Path c t
 emptyPath = Path []
 
 -- ** calculations on paths
 
-(++.) :: Path -> Label -> Path 
+(++.) :: Path c t -> Label -> Path c t 
 Path path ++. lbl = Path (Left lbl : path)
 
-(++!) :: Path -> Term -> Path 
+(++!) :: Path c t -> Term c t -> Path c t 
 Path path ++! sel = Path (Right sel : path)
 
-lintypeFollowPath :: Path -> LinType -> LinType
+lintypeFollowPath :: Path c t -> LinType c t -> LinType c t
 lintypeFollowPath (Path path) = follow path 
     where follow [] ctype = ctype
 	  follow (Right pat : path) (TblT _ ctype) = follow path ctype
 	  follow (Left  lbl : path) (RecT rec)
 	      = maybe err (follow path) $ lookup lbl rec
-	      where err = error $ "follow: " ++ prt rec ++ " . " ++ prt lbl
+	      where err = error $ "lintypeFollowPath: label not in record type"
 
-termFollowPath :: Path -> Term -> Term
+termFollowPath :: (Eq c, Eq t) => Path c t -> Term c t -> Term c t
 termFollowPath (Path path) = follow (reverse path)
     where follow [] term = term
 	  follow (Right pat : path) term = follow path (term +! pat)
 	  follow (Left  lbl : path) term = follow path (term +. lbl)
 
-lintype2paths :: Path -> LinType -> [Path]
+lintype2paths :: (Eq c, Eq t) => Path c t -> LinType c t -> [Path c t]
 lintype2paths path (ConT _ _)   = []
 lintype2paths path (StrT)       = [ path ]
 lintype2paths path (RecT rec)   = concat [ lintype2paths (path ++. lbl) ctype |
@@ -178,25 +171,25 @@ lintype2paths path (TblT pt vt) = concat [ lintype2paths (path ++! pat) vt |
 
 ----------------------------------------------------------------------
 
-instance Print Decl where
+instance Print c => Print (Decl c) where
     prt (var ::: typ) 
 	| var == anyVar = prt typ
 	| otherwise     = prt var ++ ":" ++ prt typ 
 
-instance Print Type where
+instance Print c => Print (Type c) where
     prt (cat :@ ats) = prt cat ++ prtList ats
 
 instance Print Atom where
     prt (ACon con) = prt con
     prt (AVar var) = "?" ++ prt var
 
-instance Print LinType where
+instance (Print c, Print t) => Print (LinType c t) where
     prt (RecT rec) = "{" ++ concat [ prt l ++ ":" ++ prt t ++ "; " | (l,t) <- rec ] ++ "}"
     prt (TblT t1 t2) = "(" ++ prt t1 ++ " => " ++ prt t2 ++ ")"
     prt (ConT t ts) = prt t ++ "[" ++ prtSep "|" ts ++ "]"
     prt (StrT) = "Str"
 
-instance Print Term where
+instance (Print c, Print t) => Print (Term c t) where
     prt (Arg n c p) = prt c ++ "@" ++ prt n ++ "(" ++ prt p ++ ")"
     prt (c :^ [])  = prt c 
     prt (c :^ ts)  = prt c ++ prtList ts
@@ -211,7 +204,7 @@ instance Print Term where
     prt (term :! sel) = prt term ++ "!" ++ prt sel
     prt (Var var) = "?" ++ prt var
 
-instance Print Path where
+instance (Print c, Print t) => Print (Path c t) where
     prt (Path path) = concatMap prtEither (reverse path)
 	where prtEither (Left  lbl)  = "." ++ prt lbl
 	      prtEither (Right patt) = "!" ++ prt patt