{-# OPTIONS -w #-}

module Lambdabot.Plugin.Haskell.Free.Expr where

import Lambdabot.Plugin.Haskell.Free.Type
import Lambdabot.Plugin.Haskell.Free.Util

import Prelude hiding ((<>))

varInExpr :: Var -> Expr -> Bool
varInExpr v (EBuiltin _)
    = False
varInExpr v (EVar v')
    = v == v'
varInExpr v (EVarOp _ _ v')
    = False
varInExpr v (EApp e1 e2)
    = varInExpr v e1 || varInExpr v e2
varInExpr v (ETyApp e1 t)
    = varInExpr v e1

leftVarOfExpr :: Expr -> Var
leftVarOfExpr (EVar v) = v
leftVarOfExpr (EApp e _) = leftVarOfExpr e
leftVarOfExpr (ETyApp e _) = leftVarOfExpr e

exprSubst :: Var -> Expr -> Expr -> Expr
exprSubst v e e'@(EBuiltin _)
    = e'
exprSubst v e e'@(EVar v')
    | v == v'   = e
    | otherwise = e'
exprSubst v e e'@(EVarOp _ _ v')
    | v == v'   = e
    | otherwise = e'
exprSubst v e (EApp e1 e2)
    = EApp (exprSubst v e e1) (exprSubst v e e2)
exprSubst v e (ETyApp e1 t)
    = ETyApp (exprSubst v e e1) t


type Var = String

data Fixity
    = FL | FN | FR
    deriving (Eq, Show)

data Expr
    = EVar Var
    | EBuiltin Builtin
    | EVarOp Fixity Int Var
    | EApp Expr Expr
    | ETyApp Expr Type
        deriving (Eq, Show)

data Builtin
    = BMap TyName
    | BId
    | BProj Int Int
    | BMapTuple Int
    | BArr
        deriving (Eq, Show)

data ExprCtx
    = ECDot
    | ECAppL ExprCtx Expr
    | ECAppR Expr ExprCtx
    | ECTyApp ExprCtx Type
        deriving (Eq, Show)

applySimplifierExpr :: (Expr -> Expr) -> (Expr -> Expr)
applySimplifierExpr s (EApp e1 e2)
    = EApp (s e1) (s e2)
applySimplifierExpr s (ETyApp e t)
    = ETyApp (s e) t
applySimplifierExpr s e
    = e

unzipExpr :: Expr -> ExprCtx -> Expr
unzipExpr e ECDot = e
unzipExpr e (ECAppL c e2) = unzipExpr (EApp e e2) c
unzipExpr e (ECAppR e1 c) = unzipExpr (EApp e1 e) c
unzipExpr e (ECTyApp c t) = unzipExpr (ETyApp e t) c

varInCtx :: Var -> ExprCtx -> Bool
varInCtx v ECDot
    = False
varInCtx v (ECAppL c e2)
    = varInCtx v c || varInExpr v e2
varInCtx v (ECAppR e1 c)
    = varInCtx v c || varInExpr v e1
varInCtx v (ECTyApp c _)
    = varInCtx v c

precAPP :: Int
precAPP = 10

instance Pretty Expr where
    prettyP p (EBuiltin b)
        = prettyP p b
    prettyP _ (EVar v)
        = text v
    prettyP _ (EVarOp _ _ v)
        = lparen <> text v <> rparen
    prettyP p (EApp (EApp (EVarOp fix prec op) e1) e2)
        = prettyParen (p > prec) (
            prettyP pl e1 <+> text op <+> prettyP pr e2
        )
        where
            pl = if fix == FL then prec else prec+1
            pr = if fix == FR then prec else prec+1
    prettyP p (EApp e1 e2)
        = prettyParen (p > precAPP) (
            prettyP precAPP e1 <+> prettyP (precAPP+1) e2
        )
    prettyP p (ETyApp e t)
        = prettyP precAPP e

instance Pretty Builtin where
    prettyP p (BMap "[]")   = text "$map"
    prettyP p (BMap c)      = text ("$map_" ++ c)
    prettyP p BId           = text "$id"
    prettyP p (BProj 2 1)   = text "$fst"
    prettyP p (BProj 2 2)   = text "$snd"
    prettyP p (BProj 3 1)   = text "$fst3"
    prettyP p (BProj 3 2)   = text "$snd3"
    prettyP p (BProj 3 3)   = text "$thd3"
    prettyP p (BProj l i)   = text ("$proj_" ++ show l ++ "_" ++ show i)
    prettyP p (BMapTuple 2) = text "$map_Pair"
    prettyP p (BMapTuple 3) = text "$map_Triple"
    prettyP p (BMapTuple n) = text $ "$map_Tuple" ++ show n
    prettyP p BArr          = text "$arr"

-- vim: ts=4:sts=4:expandtab:ai