module Language.Pointfree.Parser where

import Language.Pointfree.Syntax
import Language.Haskell.Exts.Syntax

hs2pf (Paren e) = hs2pf e
hs2pf (Var (UnQual (Ident "id"))) = return ID
hs2pf (Var (UnQual (Ident "fst"))) = return FST
hs2pf (Var (UnQual (Ident "snd"))) = return SND
hs2pf (Var (UnQual (Ident "inl"))) = return INL
hs2pf (Var (UnQual (Ident "inr"))) = return INR
hs2pf (Con (UnQual (Ident "Left"))) = return INL
hs2pf (Con (UnQual (Ident "Right"))) = return INR
hs2pf (Var (UnQual (Ident "app"))) = return AP
hs2pf (Var (UnQual (Ident "bang"))) = return BANG
hs2pf (Var (UnQual (Ident "inn"))) = return IN
hs2pf (Var (UnQual (Ident "out"))) = return OUT
hs2pf (Var (UnQual (Ident str))) = return $ Macro str []
hs2pf (InfixApp e1 (QVarOp (UnQual (Symbol "."))) e2)
    = do t1 <- hs2pf e1
         t2 <- hs2pf e2
         return $ t1 :.: t2
hs2pf (InfixApp e1 (QVarOp (UnQual (Symbol "/\\"))) e2)
    = do t1 <- hs2pf e1
         t2 <- hs2pf e2
         return $ t1 :/\: t2
--    hs2pf (App (App (Var (UnQual (Ident "either"))) e1) e2)
hs2pf (InfixApp e1 (QVarOp (UnQual (Symbol "\\/"))) e2)
    = do t1 <- hs2pf e1
         t2 <- hs2pf e2
         return $ t1 :\/: t2
hs2pf (InfixApp e1 (QVarOp (UnQual (Symbol sym))) e2)
    = do t1 <- hs2pf e1
         t2 <- hs2pf e2
         return $ Macro ('(':sym++")") [t1,t2]
hs2pf (App (Var (UnQual (Ident "curry"))) e) 
    = hs2pf e >>= return . Curry
hs2pf (App (App (App (Var (UnQual (Ident "hylo")))
              (Paren (ExpTypeSig _ (Var (UnQual (Ident "_L")))
               typ))) e1) e2)
    = do typ' <- hs2type typ
         t1 <- hs2pf e1
         t2 <- hs2pf e2
         return $ Hylo typ' t1 t2
hs2pf (App (App (App (Var (UnQual (Ident "hyloO")))
              (Paren (ExpTypeSig _ (Var (UnQual (Ident "_L")))
               typ))) e1) e2)
    = do typ' <- hs2type typ
         t1 <- hs2pf e1
         t2 <- hs2pf e2
         return $ HyloO typ' t1 t2
---- when "Point String" becomes "Point Pointwise.Term":
--hs2pf (App (Var (UnQual (Ident "pnt"))) pw) 
--    = hs2pw pw >>= return . Point
hs2pf (App x y) -- has to be a parametrized macro
    = do term1 <- hs2pf x
         term2 <- hs2pf y
         case term1 of (Macro v lst) -> return (Macro v (lst++[term2]))
                       x -> fail "macro expected"
hs2pf x = fail "not a valid pf term"



hs2type (TyCon (UnQual (Ident "One"))) = return One
hs2type (TyTuple _ [e1,e2])
  = do t1 <- hs2type e1
       t2 <- hs2type e2
       return $ t1 :*: t2
hs2type (TyApp (TyApp (TyCon (UnQual (Ident "Either"))) e1) e2)
  = do t1 <- hs2type e1
       t2 <- hs2type e2
       return $ t1 :+: t2
hs2type (TyFun e1 e2)
  = do t1 <- hs2type e1
       t2 <- hs2type e2
       return $ t1 :-> t2
hs2type (TyVar (Ident v)) = return $ Base v
hs2type (TyApp (TyCon (UnQual (Ident "Fix"))) e)
  = hs2func e >>= return . Fix
 where
  hs2func (TyCon (UnQual (Ident "Id"))) = return Id
  hs2func (TyApp (TyCon (UnQual (Ident "Const"))) e)
     = hs2type e >>= return . Const
  -- grammar not rich enough to allow infix constructors
  hs2func (TyApp (TyApp (TyCon (UnQual (Symbol ":*:"))) e1) e2)
     = do t1 <- hs2func e1
          t2 <- hs2func e2
          return $ t1 :**: t2
  hs2func (TyApp (TyApp (TyCon (UnQual (Symbol ":+:"))) e1) e2)
     = do t1 <- hs2func e1
          t2 <- hs2func e2
          return $ t1 :++: t2
  hs2func _ = fail "not a valid type"

hs2type _ = fail "not a valid type"