diff options
| -rw-r--r-- | GF.cabal | 3 | ||||
| -rw-r--r-- | src/PGF.hs | 5 | ||||
| -rw-r--r-- | src/PGF/Expr.hs | 20 | ||||
| -rw-r--r-- | src/PGF/Type.hs | 60 |
4 files changed, 78 insertions, 10 deletions
@@ -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 diff --git a/src/PGF.hs b/src/PGF.hs index dc777f4d5..e93b1dcb0 100644 --- a/src/PGF.hs +++ b/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) diff --git a/src/PGF/Expr.hs b/src/PGF/Expr.hs index 55bd90441..454989728 100644 --- a/src/PGF/Expr.hs +++ b/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
diff --git a/src/PGF/Type.hs b/src/PGF/Type.hs new file mode 100644 index 000000000..cfe0bbe72 --- /dev/null +++ b/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
|