darcs - DrHylo

1 module Language.Pointwise.Parser where

3 import Language.Pointwise.Syntax as Pointwise

4 import Language.Haskell.Exts.Syntax as Exts

5 import Language.Haskell.Exts.Pretty

6 import Data.Char

7 import Control.Monad

9 {-

10 Parsing of a Exp to a pointwise term.

11 It recognizes:

12 G, G1, G2 ::=

13 (G) | undefined | _L | inn G | out G

14 | 'literal' | 'var' | fix G | (G1,G2)

16 | case G of Left var1 -> G1 ; Right var2 -> G2

17 | case G of Right var1 -> G1 ; Left var2 -> G2

18 | case G of ...

19 -}

21 mkVar = Exts.Var . UnQual . Ident

23 hs2pw :: Exp -> Maybe Term

25 hs2pw (Paren e) = hs2pw e

27 -- unit -> "undefined" or "_L"

28 hs2pw (Exts.Var(UnQual(Ident "undefined"))) = return Unit

29 hs2pw (Exts.Var(UnQual(Ident "_L"))) = return Unit

31 -- Constants

32 hs2pw (App (Exts.Var (UnQual (Ident "inn"))) exp)

33 = liftM In (hs2pw exp)

34 hs2pw (App (Exts.Var (UnQual (Ident "out"))) exp)

35 = liftM Out (hs2pw exp)

36 hs2pw (Lit lit) = return $ Const $ prettyPrint lit

37 hs2pw (Exts.Var(UnQual(Ident str))) = return $ Pointwise.Var str

38 hs2pw (InfixApp e1 (QConOp (Special Cons)) e2)

39 = do t1 <- hs2pw e1

40 t2 <- hs2pw e2

41 return $ (Const ":" :@: t1) :@: t2

42 hs2pw (List []) = return $ Const "[]"

43 hs2pw (List (x:xs))

44 = do e <- hs2pw x

45 es <- hs2pw (List xs)

46 return $ (Const ":" :@: e) :@: es

48 -- Recursion

49 hs2pw (App (Exts.Var (UnQual (Ident "fix"))) exp) =

50 do term <- hs2pw exp

51 return $ Fix term

53 -- remaining

54 hs2pw (Tuple [e1,e2]) =

55 do t1 <- hs2pw e1

56 t2 <- hs2pw e2

57 return $ t1 :&: t2

58 hs2pw (App (Exts.Var (UnQual (Ident "fst"))) e) =

59 do t <- hs2pw e

60 return $ Fst t

61 hs2pw (App (Exts.Var (UnQual (Ident "snd"))) e) =

62 do t <- hs2pw e

63 return $ Snd t

64 hs2pw (App (Con (UnQual (Ident "Left"))) e) =

65 do t <- hs2pw e

66 return $ Inl t

67 hs2pw (App (Con (UnQual (Ident "Right"))) e) =

68 do t <- hs2pw e

69 return $ Inr t

70 hs2pw (App e1 e2) =

71 do t1 <- hs2pw e1

72 t2 <- hs2pw e2

73 return $ t1 :@: t2

74 hs2pw (Lambda _ [PVar(Ident str)] e) =

75 do t <- hs2pw e

76 return $ Lam str t

77 -- in "case of"'s, guards fail and declarations are lost

78 hs2pw (Exts.Case e1

79 [Alt _ (PApp (UnQual(Ident "Left"))

80 [PVar(Ident str2)]) (UnGuardedAlt e2) _,

81 Alt _ (PApp (UnQual(Ident "Right"))

82 [PVar(Ident str3)]) (UnGuardedAlt e3) _]) =

83 do t1 <- hs2pw e1

84 t2 <- hs2pw e2

85 t3 <- hs2pw e3

86 return $ Pointwise.Case t1 (Lam str2 t2) (Lam str3 t3)

87 hs2pw (Exts.Case e1

88 [Alt _ (PApp (UnQual(Ident "Right"))

89 [PVar(Ident str3)]) (UnGuardedAlt e3) _,

90 Alt _ (PApp (UnQual(Ident "Left"))

91 [PVar(Ident str2)]) (UnGuardedAlt e2) _]) =

92 do t1 <- hs2pw e1

93 t2 <- hs2pw e2

94 t3 <- hs2pw e3

95 return $ Pointwise.Case t1 (Lam str2 t2) (Lam str3 t3)

96 hs2pw (Exts.Case e alts) =

97 do t1 <- hs2pw e

98 ts <- mapM alt2pws alts

99 return $ Pointwise.Match t1 ts

100 where alt2pws (Alt _ pat (UnGuardedAlt e) _) =

101 do tp <- pat2pw pat

102 te <- hs2pw e

103 return (tp,te)

104 alt2pws _ = fail "No guards allowed."

105 hs2pw (Con (UnQual (Ident x))) = return $ Const x

106 hs2pw t = fail $ "'"++prettyPrint t++

107 "' is not a valid pointwise term."

108

109

110 hsPat2Exp :: Pat -> Exp

111 hsPat2Exp (Exts.PVar hsName) = Exts.Var $ UnQual hsName

112 hsPat2Exp (PLit hsLiteral) = Lit hsLiteral

113 hsPat2Exp (PNeg hsPat) = NegApp . hsPat2Exp $ hsPat

114 hsPat2Exp (PInfixApp hsPat1 hsQName hsPat2) =

115 let hsExp1 = hsPat2Exp hsPat1

116 hsExp2 = hsPat2Exp hsPat2

117 hsQOp = (if f hsQName then QConOp else QVarOp) hsQName

118 in InfixApp hsExp1 hsQOp hsExp2

119 where

120 f (Qual _ name) = g name

121 f (UnQual name) = g name

122 f (Special _ ) = True

123 g (Ident name) = isUpper $ head name

124 g (Symbol str) = isUpper $ head str

125 hsPat2Exp (PApp hsQName []) = Con hsQName

126 hsPat2Exp (PApp hsQName lPat) =

127 foldl App (Con hsQName) . map hsPat2Exp $ lPat

128 hsPat2Exp (PTuple lPat) = Tuple $ map hsPat2Exp lPat

129 hsPat2Exp (PList lPat) = List $ map hsPat2Exp lPat

130 hsPat2Exp (PParen hsPat) = Paren $ hsPat2Exp hsPat

131 hsPat2Exp (PRec hsQName lPatField) =

132 RecConstr hsQName (map f lPatField)

133 where

134 f (PFieldPat hsQName hsPat) = FieldUpdate hsQName $ hsPat2Exp hsPat

135 --hsPat2Exp (PAsPat hsName hsPat) = AsPat hsName (hsPat2Exp hsPat)

136 hsPat2Exp (PWildCard) = mkVar "_L"

137 --hsPat2Exp (PIrrPat hsPat) = IrrPat $ hsPat2Exp hsPat

138

139 -- this approach may be changed...

140 pat2pw = hs2pw . hsPat2Exp