darcs - DrHylo

1 module Language.Pointfree.Parser where

3 import Language.Pointfree.Syntax

4 import Language.Haskell.Exts.Syntax

5 import Control.Monad

7 hs2pf (Paren e) = hs2pf e

8 hs2pf (Var (UnQual (Ident "id"))) = return ID

9 hs2pf (Var (UnQual (Ident "fst"))) = return FST

10 hs2pf (Var (UnQual (Ident "snd"))) = return SND

11 hs2pf (Var (UnQual (Ident "inl"))) = return INL

12 hs2pf (Var (UnQual (Ident "inr"))) = return INR

13 hs2pf (Con (UnQual (Ident "Left"))) = return INL

14 hs2pf (Con (UnQual (Ident "Right"))) = return INR

15 hs2pf (Var (UnQual (Ident "app"))) = return AP

16 hs2pf (Var (UnQual (Ident "bang"))) = return BANG

17 hs2pf (Var (UnQual (Ident "inn"))) = return IN

18 hs2pf (Var (UnQual (Ident "out"))) = return OUT

19 hs2pf (Var (UnQual (Ident str))) = return $ Macro str []

20 hs2pf (InfixApp e1 (QVarOp (UnQual (Symbol "."))) e2)

21 = do t1 <- hs2pf e1

22 t2 <- hs2pf e2

23 return $ t1 :.: t2

24 hs2pf (InfixApp e1 (QVarOp (UnQual (Symbol "/\\"))) e2)

25 = do t1 <- hs2pf e1

26 t2 <- hs2pf e2

27 return $ t1 :/\: t2

28 -- hs2pf (App (App (Var (UnQual (Ident "either"))) e1) e2)

29 hs2pf (InfixApp e1 (QVarOp (UnQual (Symbol "\\/"))) e2)

30 = do t1 <- hs2pf e1

31 t2 <- hs2pf e2

32 return $ t1 :\/: t2

33 hs2pf (InfixApp e1 (QVarOp (UnQual (Symbol sym))) e2)

34 = do t1 <- hs2pf e1

35 t2 <- hs2pf e2

36 return $ Macro ('(':sym++")") [t1,t2]

37 hs2pf (App (Var (UnQual (Ident "curry"))) e)

38 = liftM Curry (hs2pf e)

39 hs2pf (App (App (App (Var (UnQual (Ident "hylo")))

40 (Paren (ExpTypeSig _ (Var (UnQual (Ident "_L")))

41 typ))) e1) e2)

42 = do typ' <- hs2type typ

43 t1 <- hs2pf e1

44 t2 <- hs2pf e2

45 return $ Hylo typ' t1 t2

46 hs2pf (App (App (App (Var (UnQual (Ident "hyloO")))

47 (Paren (ExpTypeSig _ (Var (UnQual (Ident "_L")))

48 typ))) e1) e2)

49 = do typ' <- hs2type typ

50 t1 <- hs2pf e1

51 t2 <- hs2pf e2

52 return $ HyloO typ' t1 t2

53 ---- when "Point String" becomes "Point Pointwise.Term":

54 --hs2pf (App (Var (UnQual (Ident "pnt"))) pw)

55 -- = hs2pw pw >>= return . Point

56 hs2pf (App x y) -- has to be a parametrized macro

57 = do term1 <- hs2pf x

58 term2 <- hs2pf y

59 case term1 of (Macro v lst) -> return (Macro v (lst++[term2]))

60 x -> fail "macro expected"

61 hs2pf x = fail "not a valid pf term"

65 hs2type (TyCon (UnQual (Ident "One"))) = return One

66 hs2type (TyTuple _ [e1,e2])

67 = do t1 <- hs2type e1

68 t2 <- hs2type e2

69 return $ t1 :*: t2

70 hs2type (TyApp (TyApp (TyCon (UnQual (Ident "Either"))) e1) e2)

71 = do t1 <- hs2type e1

72 t2 <- hs2type e2

73 return $ t1 :+: t2

74 hs2type (TyFun e1 e2)

75 = do t1 <- hs2type e1

76 t2 <- hs2type e2

77 return $ t1 :-> t2

78 hs2type (TyVar (Ident v)) = return $ Base v

79 hs2type (TyApp (TyCon (UnQual (Ident "Fix"))) e)

80 = liftM Fix (hs2func e)

81 where

82 hs2func (TyCon (UnQual (Ident "Id"))) = return Id

83 hs2func (TyApp (TyCon (UnQual (Ident "Const"))) e)

84 = liftM Const (hs2type e)

85 -- grammar not rich enough to allow infix constructors

86 hs2func (TyApp (TyApp (TyCon (UnQual (Symbol ":*:"))) e1) e2)

87 = do t1 <- hs2func e1

88 t2 <- hs2func e2

89 return $ t1 :**: t2

90 hs2func (TyApp (TyApp (TyCon (UnQual (Symbol ":+:"))) e1) e2)

91 = do t1 <- hs2func e1

92 t2 <- hs2func e2

93 return $ t1 :++: t2

94 hs2func _ = fail "not a valid type"

96 hs2type _ = fail "not a valid type"