"Committed_by_peb"

src/GF/Formalism/SimpleGFC.hs

@@ -0,0 +1,217 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/11 13:52:50 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Simplistic GFC format
+-----------------------------------------------------------------------------
+
+module GF.Formalism.SimpleGFC where
+
+import Monad (liftM)
+import qualified AbsGFC 
+import qualified Ident 
+import GF.Formalism.GCFG
+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
+
+----------------------------------------------------------------------
+
+-- * simple GFC
+
+type SimpleGrammar = Grammar Decl Name LinType (Maybe Term)
+type SimpleRule    = Rule    Decl Name LinType (Maybe Term)
+
+-- ** 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)
+
+decl2cat :: Decl -> Cat
+decl2cat (_ ::: (cat :@ _)) = cat
+
+-- ** linearization types and terms
+
+data LinType = RecT [(Label, LinType)]
+	     | TblT LinType LinType
+	     | ConT Constr [Term]
+	     | StrT
+	       deriving (Eq, Ord, Show)
+
+isBaseType :: LinType -> 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
+	    deriving (Eq, Ord, Show)
+
+-- ** calculations on terms
+
+(+.) :: Term -> Label -> Term
+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
+Arg arg cat path +. lbl = Arg arg cat (path ++. lbl)
+term +. lbl = term :. lbl
+
+(+!) :: Term -> Term -> Term
+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
+Arg arg cat path +! pat = Arg arg cat (path ++! pat)
+term +! pat = term :! pat
+
+(?++) :: Term -> Term -> Term
+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 terms0 = case concatMap flatten terms0 of
+		    [term] -> term
+		    terms  -> Variants terms
+    where flatten (Variants ts) = ts
+	  flatten  t      = [t]
+
+-- ** enumerations
+
+enumerateTerms :: Maybe Term -> LinType -> [Term]
+enumerateTerms arg (StrT) = maybe err return arg
+    where err = error "enumeratePatterns: parameter type should not be string"
+enumerateTerms arg (ConT _ terms) = terms
+enumerateTerms arg (RecT rtype) 
+    = liftM Rec $ mapM enumAssign rtype
+    where enumAssign (lbl, ctype) = liftM ((,) lbl) $ enumerateTerms arg ctype
+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 = enumerateTerms Nothing
+
+----------------------------------------------------------------------
+
+-- * paths of record projections and table selections
+
+newtype Path = Path [Either Label Term] deriving (Eq, Ord, Show)
+
+emptyPath :: Path
+emptyPath = Path []
+
+-- ** calculations on paths
+
+(++.) :: Path -> Label -> Path 
+Path path ++. lbl = Path (Left lbl : path)
+
+(++!) :: Path -> Term -> Path 
+Path path ++! sel = Path (Right sel : path)
+
+lintypeFollowPath :: Path -> LinType -> LinType
+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
+
+termFollowPath :: Path -> Term -> Term
+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 path (ConT _ _)   = []
+lintype2paths path (StrT)       = [ path ]
+lintype2paths path (RecT rec)   = concat [ lintype2paths (path ++. lbl) ctype |
+					   (lbl, ctype) <- rec ]
+lintype2paths path (TblT pt vt) = concat [ lintype2paths (path ++! pat) vt |
+					   pat <- enumeratePatterns pt ]
+
+----------------------------------------------------------------------
+
+instance Print Decl where
+    prt (var ::: typ) 
+	| var == anyVar = prt typ
+	| otherwise     = prt var ++ ":" ++ prt typ 
+
+instance Print Type 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
+    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
+    prt (Arg n c p) = prt c ++ "@" ++ prt n ++ "(" ++ prt p ++ ")"
+    prt (c :^ [])  = prt c 
+    prt (c :^ ts)  = prt c ++ prtList ts
+    prt (Rec rec)   = "{" ++ concat [ prt l ++ "=" ++ prt t ++ "; " | (l,t) <- rec ] ++ "}"
+    prt (Tbl tbl)   = "[" ++ concat [ prt p ++ "=>" ++ prt t ++ "; " | (p,t) <- tbl ] ++ "]"
+    prt (Variants ts)  = "{| " ++ prtSep " | " ts ++ " |}"
+    prt (t1 :++ t2) = prt t1 ++ "++" ++ prt t2
+    prt (Token t)   = prt t
+    prt (Empty)     = "[]"
+    prt (Wildcard)  = "_"
+    prt (term :. lbl) = prt term ++ "." ++ prt lbl
+    prt (term :! sel) = prt term ++ "!" ++ prt sel
+    prt (Var var) = "?" ++ prt var
+
+instance Print Path where
+    prt (Path path) = concatMap prtEither (reverse path)
+	where prtEither (Left  lbl)  = "." ++ prt lbl
+	      prtEither (Right patt) = "!" ++ prt patt