changed names of resource-1.3; added a note on homepage on release

4 files changed, 398 insertions, 0 deletions

diff --git a/src/PGF/Raw/Abstract.hs b/src/PGF/Raw/Abstract.hs
new file mode 100644
index 000000000..77d919a2d
--- /dev/null
+++ b/src/PGF/Raw/Abstract.hs
@@ -0,0 +1,14 @@
+module PGF.Raw.Abstract where
+
+data Grammar =
+   Grm [RExp]
+  deriving (Eq,Ord,Show)
+
+data RExp =
+   App String [RExp]
+ | AInt Integer
+ | AStr String
+ | AFlt Double
+ | AMet
+  deriving (Eq,Ord,Show)
+
diff --git a/src/PGF/Raw/Convert.hs b/src/PGF/Raw/Convert.hs
new file mode 100644
index 000000000..af3708eb5
--- /dev/null
+++ b/src/PGF/Raw/Convert.hs
@@ -0,0 +1,248 @@
+module PGF.Raw.Convert (toPGF,fromPGF) where
+
+import PGF.CId
+import PGF.Data
+import PGF.Raw.Abstract
+import PGF.BuildParser (buildParserInfo)
+import PGF.Parsing.FCFG.Utilities
+
+import qualified Data.Array as Array
+import qualified Data.Map   as Map
+
+pgfMajorVersion, pgfMinorVersion :: Integer
+(pgfMajorVersion, pgfMinorVersion) = (1,0)
+
+-- convert parsed grammar to internal PGF
+
+toPGF :: Grammar -> PGF
+toPGF (Grm [
+  App "pgf" (AInt v1 : AInt v2 : App a []:cs),
+  App "flags"     gfs, 
+  ab@(
+    App "abstract" [
+      App "fun"   fs,
+      App "cat"   cts
+      ]), 
+  App "concrete" ccs
+  ]) = PGF {
+    absname = mkCId a,
+    cncnames = [mkCId c | App c [] <- cs],
+    gflags = Map.fromAscList [(mkCId f,v) | App f [AStr v] <- gfs],
+    abstract = 
+     let
+      aflags  = Map.fromAscList [(mkCId f,v) | App f [AStr v] <- gfs]
+      lfuns   = [(mkCId f,(toType typ,toExp def)) | App f [typ, def] <- fs]
+      funs    = Map.fromAscList lfuns
+      lcats   = [(mkCId c, Prelude.map toHypo hyps) | App c hyps <- cts]
+      cats    = Map.fromAscList lcats
+      catfuns = Map.fromAscList 
+        [(cat,[f | (f, (DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
+     in Abstr aflags funs cats catfuns,
+    concretes = Map.fromAscList [(mkCId lang, toConcr ts) | App lang ts <- ccs]
+    }
+ where
+
+toConcr :: [RExp] -> Concr
+toConcr = foldl add (Concr {
+               cflags       = Map.empty,
+               lins         = Map.empty,
+               opers        = Map.empty,
+               lincats      = Map.empty,
+               lindefs      = Map.empty,
+               printnames   = Map.empty,
+               paramlincats = Map.empty,
+               parser       = Nothing
+             })
+  where
+    add :: Concr -> RExp -> Concr
+    add cnc (App "flags" ts)     = cnc { cflags = Map.fromAscList [(mkCId f,v) | App f [AStr v] <- ts] }
+    add cnc (App "lin" ts)       = cnc { lins = mkTermMap ts }
+    add cnc (App "oper" ts)      = cnc { opers = mkTermMap ts }
+    add cnc (App "lincat" ts)    = cnc { lincats = mkTermMap ts }
+    add cnc (App "lindef" ts)    = cnc { lindefs = mkTermMap ts }
+    add cnc (App "printname" ts) = cnc { printnames = mkTermMap ts }
+    add cnc (App "param" ts)     = cnc { paramlincats = mkTermMap ts }
+    add cnc (App "parser" ts)    = cnc { parser = Just (toPInfo ts) }
+
+toPInfo :: [RExp] -> ParserInfo
+toPInfo [App "rules" rs, App "startupcats" cs] = buildParserInfo (rules, cats)
+  where 
+    rules = map toFRule rs
+    cats = Map.fromList [(mkCId c, map expToInt fs) | App c fs <- cs]
+
+    toFRule :: RExp -> FRule
+    toFRule (App "rule"
+              [n,                      
+               App "cats" (rt:at),
+               App "R" ls]) = FRule fun prof args res lins
+      where 
+        (fun,prof) = toFName n
+        args = map expToInt at
+        res  = expToInt rt
+        lins = mkArray [mkArray [toSymbol s | s <- l] | App "S" l <- ls]
+
+toFName :: RExp -> (CId,[Profile])
+toFName (App "_A" [x]) = (wildCId, [[expToInt x]])
+toFName (App f ts)     = (mkCId f, map toProfile ts)
+    where
+      toProfile :: RExp -> Profile
+      toProfile AMet           = []
+      toProfile (App "_A" [t]) = [expToInt t]
+      toProfile (App "_U" ts)  = [expToInt t | App "_A" [t] <- ts]
+
+toSymbol :: RExp -> FSymbol
+toSymbol (App "P" [n,l]) = FSymCat (expToInt l) (expToInt n)
+toSymbol (AStr t) = FSymTok t
+
+toType :: RExp -> Type
+toType e = case e of
+  App cat [App "H" hypos, App "X" exps] -> 
+    DTyp (map toHypo hypos) (mkCId cat) (map toExp exps) 
+  _ -> error $ "type " ++ show e
+
+toHypo :: RExp -> Hypo
+toHypo e = case e of
+  App x [typ] -> Hyp (mkCId x) (toType typ)
+  _ -> error $ "hypo " ++ show e
+
+toExp :: RExp -> Expr
+toExp e = case e of
+  App "Abs" [App x [], exp] -> EAbs (mkCId x) (toExp exp)
+  App "App" [e1,e2] -> EApp (toExp e1) (toExp e2)
+  App "Eq" eqs -> EEq [Equ (map toExp ps) (toExp v) | App "E" (v:ps) <- eqs]
+  App "Var" [App i []] -> EVar (mkCId i)
+  AMet   -> EMeta  0
+  AInt i -> ELit (LInt i)
+  AFlt i -> ELit (LFlt i)
+  AStr i -> ELit (LStr i)
+  _ -> error $ "exp " ++ show e
+
+toTerm :: RExp -> Term
+toTerm e = case e of
+  App "R" es    -> R  (map toTerm es)
+  App "S" es    -> S  (map toTerm es)
+  App "FV" es   -> FV (map toTerm es)
+  App "P" [e,v] -> P  (toTerm e) (toTerm v)
+  App "W" [AStr s,v] -> W s (toTerm v)
+  App "A" [AInt i] -> V (fromInteger i)
+  App f []  -> F (mkCId f)
+  AInt i -> C (fromInteger i)
+  AMet   -> TM "?"
+  AStr s -> K (KS s) ----
+  _ -> error $ "term " ++ show e
+
+------------------------------
+--- from internal to parser --
+------------------------------
+
+fromPGF :: PGF -> Grammar
+fromPGF pgf0 = Grm [
+  App "pgf" (AInt pgfMajorVersion:AInt pgfMinorVersion
+             : App (prCId (absname pgf)) [] : map (flip App [] . prCId) (cncnames pgf)), 
+  App "flags" [App (prCId f) [AStr v] | (f,v) <- Map.toList (gflags pgf `Map.union` aflags apgf)],
+  App "abstract" [
+    App "fun"   [App (prCId f) [fromType t,fromExp d] | (f,(t,d)) <- Map.toList (funs apgf)],
+    App "cat"   [App (prCId f) (map fromHypo hs) | (f,hs) <- Map.toList (cats apgf)]
+    ],
+  App "concrete" [App (prCId lang) (fromConcrete c) | (lang,c) <- Map.toList (concretes pgf)]
+  ]
+ where
+  pgf = utf8GFCC pgf0
+  apgf = abstract pgf
+  fromConcrete cnc = [
+      App "flags"     [App (prCId f) [AStr v]     | (f,v) <- Map.toList (cflags cnc)],
+      App "lin"       [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (lins cnc)],
+      App "oper"      [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (opers cnc)],
+      App "lincat"    [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (lincats cnc)],
+      App "lindef"    [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (lindefs cnc)],
+      App "printname" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (printnames cnc)],
+      App "param"     [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (paramlincats cnc)]
+     ] ++ maybe [] (\p -> [fromPInfo p]) (parser cnc)
+
+fromType :: Type -> RExp
+fromType e = case e of
+  DTyp hypos cat exps -> 
+    App (prCId cat) [
+      App "H" (map fromHypo hypos), 
+      App "X" (map fromExp exps)] 
+
+fromHypo :: Hypo -> RExp
+fromHypo e = case e of
+  Hyp x typ -> App (prCId x) [fromType typ]
+
+fromExp :: Expr -> RExp
+fromExp e = case e of
+  EAbs x exp   -> App "Abs" [App (prCId x) [], fromExp exp]
+  EApp e1 e2 -> App "App" [fromExp e1, fromExp e2]
+  EVar   x -> App "Var" [App (prCId x) []]
+  ELit (LStr s) -> AStr s
+  ELit (LFlt d) -> AFlt d
+  ELit (LInt i) -> AInt (toInteger i)
+  EMeta _  -> AMet ----
+  EEq eqs  -> 
+    App "Eq" [App "E" (map fromExp (v:ps)) | Equ ps v <- eqs]
+
+fromTerm :: Term -> RExp
+fromTerm e = case e of
+  R es    -> App "R" (map fromTerm es)
+  S es    -> App "S" (map fromTerm es)
+  FV es   -> App "FV" (map fromTerm es)
+  P e v   -> App "P"  [fromTerm e, fromTerm v]
+  W s v   -> App "W" [AStr s, fromTerm v]
+  C i     -> AInt (toInteger i)
+  TM _    -> AMet
+  F f     -> App (prCId f) []
+  V i     -> App "A" [AInt (toInteger i)]
+  K (KS s) -> AStr s ----
+  K (KP d vs) -> App "FV" (str d : [str v | Alt v _ <- vs]) ----
+ where
+   str v = App "S" (map AStr v)
+
+-- ** Parsing info
+
+fromPInfo :: ParserInfo -> RExp
+fromPInfo p = App "parser" [
+          App "rules"         [fromFRule rule | rule <- Array.elems (allRules p)],
+          App "startupcats"   [App (prCId f) (map intToExp cs) | (f,cs) <- Map.toList (startupCats p)]
+        ]
+
+fromFRule :: FRule -> RExp
+fromFRule (FRule fun prof args res lins) = 
+    App "rule" [fromFName (fun,prof),
+                App "cats" (intToExp res:map intToExp args),
+                App "R" [App "S" [fromSymbol s | s <- Array.elems l] | l <- Array.elems lins]
+               ]
+
+fromFName :: (CId,[Profile]) -> RExp
+fromFName (f,ps) | f == wildCId = fromProfile (head ps)
+                 | otherwise    = App (prCId f) (map fromProfile ps)
+  where
+    fromProfile :: Profile -> RExp
+    fromProfile []   = AMet
+    fromProfile [x]  = daughter x
+    fromProfile args = App "_U" (map daughter args)
+
+    daughter n = App "_A" [intToExp n]
+
+fromSymbol :: FSymbol -> RExp
+fromSymbol (FSymCat l n) = App "P" [intToExp n, intToExp l]
+fromSymbol (FSymTok t) = AStr t
+
+-- ** Utilities
+
+mkTermMap :: [RExp] -> Map.Map CId Term
+mkTermMap ts = Map.fromAscList [(mkCId f,toTerm v) | App f [v] <- ts]
+
+mkArray :: [a] -> Array.Array Int a
+mkArray xs = Array.listArray (0, length xs - 1) xs
+
+expToInt :: Integral a => RExp -> a
+expToInt (App "neg" [AInt i]) = fromIntegral (negate i)
+expToInt (AInt i) = fromIntegral i
+
+expToStr :: RExp -> String
+expToStr (AStr s) = s
+
+intToExp :: Integral a => a -> RExp
+intToExp x | x < 0 = App "neg" [AInt (fromIntegral (negate x))]
+           | otherwise =  AInt (fromIntegral x)
diff --git a/src/PGF/Raw/Parse.hs b/src/PGF/Raw/Parse.hs
new file mode 100644
index 000000000..671183ba4
--- /dev/null
+++ b/src/PGF/Raw/Parse.hs
@@ -0,0 +1,101 @@
+module PGF.Raw.Parse (parseGrammar) where
+
+import PGF.CId
+import PGF.Raw.Abstract
+
+import Control.Monad
+import Data.Char
+import qualified Data.ByteString.Char8 as BS
+
+parseGrammar :: String -> IO Grammar
+parseGrammar s = case runP pGrammar s of
+                   Just (x,"") -> return x
+                   _           -> fail "Parse error"
+
+pGrammar :: P Grammar
+pGrammar = liftM Grm pTerms
+
+pTerms :: P [RExp]
+pTerms = liftM2 (:) (pTerm 1) pTerms <++ (skipSpaces >> return [])
+
+pTerm :: Int -> P RExp
+pTerm n = skipSpaces >> (pParen <++ pApp <++ pNum <++ pStr <++ pMeta)
+  where pParen = between (char '(') (char ')') (pTerm 0)
+        pApp = liftM2 App pIdent (if n == 0 then pTerms else return [])
+        pStr = char '"' >> liftM AStr (manyTill (pEsc <++ get) (char '"'))
+        pEsc = char '\\' >> get
+        pNum = do x <- munch1 isDigit
+                  ((char '.' >> munch1 isDigit >>= \y -> return (AFlt (read (x++"."++y))))
+                   <++
+                   return (AInt (read x)))
+        pMeta = char '?' >> return AMet
+        pIdent = liftM2 (:) (satisfy isIdentFirst) (munch isIdentRest)
+        isIdentFirst c = c == '_' || isAlpha c
+        isIdentRest c = c == '_' || c == '\'' || isAlphaNum c
+
+-- Parser combinators with only left-biased choice
+
+newtype P a = P { runP :: String -> Maybe (a,String) }
+
+instance Monad P where
+    return x = P (\ts -> Just (x,ts))
+    P p >>= f = P (\ts -> p ts >>= \ (x,ts') -> runP (f x) ts')
+    fail _ = pfail
+
+instance MonadPlus P where
+    mzero = pfail
+    mplus = (<++)
+
+
+get :: P Char
+get = P (\ts -> case ts of
+                  [] -> Nothing
+                  c:cs -> Just (c,cs))
+
+look :: P String
+look = P (\ts -> Just (ts,ts))
+
+(<++) :: P a -> P a -> P a
+P p <++ P q = P (\ts -> p ts `mplus` q ts)
+
+pfail :: P a
+pfail = P (\ts -> Nothing)
+
+satisfy :: (Char -> Bool) -> P Char
+satisfy p = do c <- get
+               if p c then return c else pfail
+
+char :: Char -> P Char
+char c = satisfy (c==)
+
+string :: String -> P String
+string this = look >>= scan this
+    where
+      scan []     _               = return this
+      scan (x:xs) (y:ys) | x == y = get >> scan xs ys
+      scan _      _               = pfail
+
+skipSpaces :: P ()
+skipSpaces = look >>= skip
+    where
+      skip (c:s) | isSpace c = get >> skip s
+      skip _                 = return ()
+
+manyTill :: P a -> P end -> P [a]
+manyTill p end = scan
+  where scan = (end >> return []) <++ liftM2 (:) p scan
+
+munch :: (Char -> Bool) -> P String
+munch p = munch1 p <++ return []
+
+munch1 :: (Char -> Bool) -> P String
+munch1 p = liftM2 (:) (satisfy p) (munch p)
+
+choice :: [P a] -> P a
+choice = msum
+
+between :: P open -> P close -> P a -> P a
+between open close p = do open
+                          x <- p
+                          close
+                          return x
diff --git a/src/PGF/Raw/Print.hs b/src/PGF/Raw/Print.hs
new file mode 100644
index 000000000..d34adbc2b
--- /dev/null
+++ b/src/PGF/Raw/Print.hs
@@ -0,0 +1,35 @@
+module PGF.Raw.Print (printTree) where
+
+import PGF.CId
+import PGF.Raw.Abstract
+
+import Data.List (intersperse)
+import Numeric (showFFloat)
+import qualified Data.ByteString.Char8 as BS
+
+printTree :: Grammar -> String
+printTree g = prGrammar g ""
+
+prGrammar :: Grammar -> ShowS
+prGrammar (Grm xs) = prRExpList xs
+
+prRExp :: Int -> RExp -> ShowS
+prRExp _ (App x []) = showString x
+prRExp n (App x xs) = p (showString x . showChar ' ' . prRExpList xs)
+    where p s = if n == 0 then s else showChar '(' . s . showChar ')'
+prRExp _ (AInt x) = shows x
+prRExp _ (AStr x) = showChar '"' . concatS (map mkEsc x) . showChar '"'
+prRExp _ (AFlt x) = showFFloat Nothing x
+prRExp _ AMet = showChar '?'
+
+mkEsc :: Char -> ShowS
+mkEsc s = case s of
+  '"'  -> showString "\\\""
+  '\\' -> showString "\\\\"
+  _    -> showChar s
+
+prRExpList :: [RExp] -> ShowS
+prRExpList = concatS . intersperse (showChar ' ') . map (prRExp 1)
+
+concatS :: [ShowS] -> ShowS
+concatS = foldr (.) id