add parser and pretty printer for types

GF.cabal

@@ -574,6 +574,7 @@ library
     PGF.Parsing.FCFG.Incremental
     PGF.Parsing.FCFG
     PGF.Expr
+    PGF.Type
     PGF.Raw.Parse
     PGF.Raw.Print
     PGF.Raw.Convert
@@ -680,6 +681,8 @@ executable gf
     PGF
     PGF.CId
     PGF.Data
+    PGF.Expr
+    PGF.Type
     PGF.Macros
     PGF.Generate
     PGF.Linearize

src/PGF.hs

@@ -26,6 +26,10 @@ module PGF(
            
            -- ** Category
            Category, categories, startCat,
+           
+           -- * Types
+           Type(..),
+           showType, readType,
 
            -- * Expressions
            -- ** Tree
@@ -64,6 +68,7 @@ import PGF.Paraphrase
 import PGF.Macros
 import PGF.Data
 import PGF.Expr
+import PGF.Type
 import PGF.Raw.Convert
 import PGF.Raw.Parse
 import PGF.Raw.Print (printTree)

src/PGF/Expr.hs

@@ -7,7 +7,7 @@ module PGF.Expr(readTree, showTree, pTree, ppTree,
                 Value(..), Env, eval, apply,
 
                 -- helpers
-                pIdent,pStr
+                pIdent,pStr,pFactor
                ) where
 
 import PGF.CId
@@ -68,18 +68,9 @@ pExpr = RP.skipSpaces >> (pAbs RP.<++ pTerm RP.<++ pEqs)
   where
     pTerm   =       fmap (foldl1 EApp) (RP.sepBy1 pFactor RP.skipSpaces)
 
-    pFactor =       fmap EVar pCId
-            RP.<++  fmap ELit pLit
-            RP.<++  pMeta
-            RP.<++  RP.between (RP.char '(') (RP.char ')') pExpr
-
     pAbs = do xs <- RP.between (RP.char '\\') (RP.skipSpaces >> RP.string "->") (RP.sepBy1 (RP.skipSpaces >> pCId) (RP.skipSpaces >> RP.char ','))
               e  <- pExpr
               return (foldr EAbs e xs)
-
-    pMeta = do RP.char '?'
-               n <- fmap read (RP.munch1 isDigit)
-               return (EMeta n)
                
     pEqs = fmap EEq $
            RP.between (RP.skipSpaces >> RP.char '{')
@@ -92,6 +83,15 @@ pExpr = RP.skipSpaces >> (pAbs RP.<++ pTerm RP.<++ pEqs)
              e <- pExpr
              return (Equ pats e)
 
+pFactor =       fmap EVar pCId
+        RP.<++  fmap ELit pLit
+        RP.<++  pMeta
+        RP.<++  RP.between (RP.char '(') (RP.char ')') pExpr
+  where
+    pMeta = do RP.char '?'
+               n <- fmap read (RP.munch1 isDigit)
+               return (EMeta n)
+
 pLit :: RP.ReadP Literal
 pLit = pNum RP.<++ liftM LStr pStr
 

src/PGF/Type.hs

@@ -0,0 +1,60 @@
+module PGF.Type ( readType, showType, pType, ppType ) where
+
+import PGF.CId
+import PGF.Data
+import PGF.Expr
+import Data.Char
+import qualified Text.PrettyPrint as PP
+import qualified Text.ParserCombinators.ReadP as RP
+import Control.Monad
+import Debug.Trace
+
+-- | parses 'String' as an expression
+readType :: String -> Maybe Type
+readType s = case [x | (x,cs) <- RP.readP_to_S pType s, all isSpace cs] of
+               [x] -> Just x
+               _   -> Nothing
+
+-- | renders type as 'String'
+showType :: Type -> String
+showType = PP.render . ppType 0
+
+pType = do
+  RP.skipSpaces
+  hyps <- RP.sepBy (pHypo >>= \h -> RP.string "->" >> return h) RP.skipSpaces
+  RP.skipSpaces
+  (cat,args) <- pAtom
+  return (DTyp hyps cat args)
+  where
+    pHypo =
+      do (cat,args) <- pAtom
+         return (Hyp wildCId (DTyp [] cat args))
+      RP.<++
+      (RP.between (RP.char '(') (RP.char ')') $ do
+         var <- RP.option wildCId $ do
+                     v <- pIdent
+                     RP.skipSpaces
+                     RP.string ":"
+                     return (mkCId v)
+         ty <- pType
+         return (Hyp var ty))
+
+    pAtom = do
+      cat <- pIdent
+      RP.skipSpaces
+      args <- RP.sepBy pFactor RP.skipSpaces
+      return (mkCId cat, args)
+
+
+ppType d (DTyp ctxt cat args)
+  | null ctxt = ppRes cat args
+  | otherwise = ppParens (d > 0) (foldr ppCtxt (ppRes cat args) ctxt)
+  where
+    ppCtxt (Hyp x typ) doc
+      | x == wildCId = ppType 1 typ PP.<+> PP.text "->" PP.<+> doc
+      | otherwise    = PP.parens (PP.text (prCId x) PP.<+> PP.char ':' PP.<+> ppType 0 typ) PP.<+> PP.text "->" PP.<+> doc
+
+    ppRes cat es = PP.text (prCId cat) PP.<+> PP.hsep (map (ppExpr 2) es)
+
+ppParens True  = PP.parens
+ppParens False = id