{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}

-- The Timber compiler <timber-lang.org>
--
-- Copyright 2008-2009 Johan Nordlander <nordland@csee.ltu.se>
-- All rights reserved.
-- 
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions
-- are met:
-- 
-- 1. Redistributions of source code must retain the above copyright
--    notice, this list of conditions and the following disclaimer.
-- 
-- 2. Redistributions in binary form must reproduce the above copyright
--    notice, this list of conditions and the following disclaimer in the
--    documentation and/or other materials provided with the distribution.
-- 
-- 3. Neither the names of the copyright holder and any identified
--    contributors, nor the names of their affiliations, may be used to 
--    endorse or promote products derived from this software without 
--    specific prior written permission.
-- 
-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-- POSSIBILITY OF SUCH DAMAGE.

module Syntax where

import Common
import Lexer
import PP
import Data.Binary

data Module = Module Name [Import] [Decl] [Decl]
            deriving  (Show)

data Import = Import Bool Name 
            deriving (Show)
            
data Decl   = DKSig   Name Kind
            | DData   Name [Name] [Type] [Constr]
            | DRec    Bool Name [Name] [Type] [Sig]
            | DType   Name [Name] Type   -- removed by desugaring
--            | DInst   Type [Bind]        --          -"-
            | DPSig   Name Type 
            | DDefault [Default Type]  
            | DInstance [Name]
            | DTClass [Name]
            | DBind   [Bind]
            deriving  (Eq,Show)

data Constr =  Constr Name [Type] [Pred]
            deriving (Eq,Show)

data Sig    = Sig [Name] Type
            deriving (Eq,Show)

data Bind   = BSig    [Name] Type
            | BEqn    Lhs (Rhs Exp)
            deriving  (Eq,Show)


type Eqn    = (Lhs, Rhs Exp)

data Type   = TQual   Type [Pred]
            | TCon    Name
            | TVar    Name
            | TAp     Type Type
            | TSub    Type Type
            | TWild
            | TList   Type
            | TTup    [Type]
            | TFun    [Type] Type
            deriving  (Eq,Show)

data Pred   = PType Type
            | PKind   Name Kind
            deriving (Eq,Show)
            
data Lhs    = LFun Name [Pat]
            | LPat Pat
            deriving (Eq,Show)

type Pat    = Exp

data Exp    = EVar    Name
            | EAp     Exp Exp
            | ECon    Name
            | ESel    Name
            | ELit    Lit
            | ETup    [Exp]
            | EList   [Exp]
            | EWild
            | ESig    Exp Type
            | ERec    (Maybe (Name,Bool)) [Field]
            -- pattern syntax ends here
            | EBStruct (Maybe Name) [Name] [Bind]  -- struct value in bindlist syntax
            | ELam    [Pat] Exp
            | ELet    [Bind] Exp
            | ECase   Exp [Alt Exp]
-- the following and ETup, EList removed in desugaring
            | EIf     Exp Exp Exp
            | ENeg    Exp
            | ESeq    Exp (Maybe Exp) Exp
            | EComp   Exp [Qual]
            | ESectR  Exp Name
            | ESectL  Name Exp
            | ESelect Exp Name
            | EDo     (Maybe Name) (Maybe Type) [Stmt] 
            | ETempl  (Maybe Name) (Maybe Type) [Stmt]
            | EAct    (Maybe Name) [Stmt] 
            | EReq    (Maybe Name) [Stmt] 
            | EAfter  Exp Exp
            | EBefore Exp Exp
            deriving  (Eq,Show)

data Field  = Field   Name Exp
            deriving (Eq,Show)
    
data Rhs a  = RExp    a
            | RGrd    [GExp a]
            | RWhere  (Rhs a) [Bind]
            deriving  (Eq,Show)

data GExp a = GExp    [Qual] a
            deriving (Eq,Show)
            
data Alt a  = Alt     Pat (Rhs a)
            deriving  (Eq,Show)

data Qual   = QExp    Exp
            | QGen    Pat Exp
            | QLet    [Bind]
            deriving  (Eq,Show)
            
data Stmt   = SExp    Exp
            | SRet    Exp
            | SGen    Pat Exp
            | SBind   [Bind]
            | SAss    Pat Exp
            | SForall [Qual] [Stmt]
            | SIf     Exp [Stmt]
            | SElsif  Exp [Stmt]
            | SElse   [Stmt]
            | SCase   Exp [Alt [Stmt]]
            deriving  (Eq,Show)


-- Primitives ----------------------------------------------------------------

cons x xs                       = EAp (EAp (ECon (prim CONS)) x) xs
nil                             = ECon (prim NIL)
true                            = ECon (prim TRUE)
false                           = ECon (prim FALSE)


-- Helper functions ----------------------------------------------------------------

imports c is 
      | str c == "Prelude"      = []
      | otherwise               = Import True (name0 "Prelude") : is

mkModule c (is,ds,ps)           = Module c (imports c is) ds ps

newEVarPos v p                  = do i <- newNamePos v p
                                     return (EVar i)

op2exp c                        = if isCon c then ECon c else EVar c

isEVar (EVar _)                 = True
isEVar (EWild)                  = True
isEVar _                        = False

isEConApp (EAp e es)            = isEConApp e
isEConApp (ECon _)              = True
isEConApp _                     = False

isELit (ELit _)                 = True
isELit _                        = False

isERec (ERec _ _)               = True
isERec _                        = False

isESigVar (ESig e _)            = isEVar e
isESigVar e                     = isEVar e

isETup (ETup _)                 = True
isETup _                        = False

isSAss (SAss _ _)               = True
isSAss _                        = False

isSGen (SGen _ _)               = True
isSGen _                        = False

isSBind (SBind _)               = True
isSBind _                       = False

isDBind (DBind _)               = True
isDBind _                       = False

isBSig (BSig _ _)               = True
isBSig _                        = False

isPKind (PKind _ _)             = True
isPKind _                       = False

tAp isDType (DType _ _ _)       = True
isDType _                       = False

isLPatEqn (BEqn (LPat _) _)     = True
isLPatEqn _                     = False

tupSize (ETup es)               = length es
tupSize _                       = -1


eFlat e                         = flat e []
  where flat (EAp e e') es      = flat e (e':es)
        flat e es               = (e,es)

eLam [] e                       = e
eLam ps (ELam ps' e)            = ELam (ps++ps') e
eLam ps e                       = ELam ps e

rAp (RExp e) es                 = RExp (foldl EAp e es)
rAp (RWhere rhs bs) es          = RWhere (rAp rhs es) bs
rAp (RGrd gs) es                = RGrd [ GExp qs (foldl EAp e es) | GExp qs e <- gs ]


eLet [] e                       = e
eLet bs e                       = ELet bs e


simpleEqn x e                   = BEqn (LFun x []) (RExp e)


exp2lhs e                       = case eFlat e of
                                       (EVar v, ps)
                                         |not(null ps) -> LFun v ps
                                       _               -> LPat e

tFun [] t                       = t
tFun ts t                       = TFun ts t

tQual ps (TQual t ps')          = TQual t (ps++ps')
tQual ps t                      = TQual t ps

tFlat t                         = flat t []
  where flat (TAp t1 t2) ts     = flat t1 (t2:ts)
        flat t ts               = (t,ts)


type2cons (TQual t ps)          = case tFlat t of
                                    (TCon c,ts) -> Constr c ts ps
                                    _           -> errorTree "Bad type constructor in" t
type2cons t                     = case tFlat t of
                                    (TCon c,ts) -> Constr c ts []
                                    _           -> errorTree "Bad type constructor in" t

type2head (TQual t ps)          = type2head t
type2head t                     = case tFlat t of
                                    (TCon c,ts) -> c
                                    _           -> errorTree "Bad instance head in" t

stripSigs (ESig p _)            = p
stripSigs p                     = p


tyCons :: Type -> [Name]
tyCons (TQual t ps)             = nub (tyCons t ++ concatMap tC ps)
   where tC (PType t)           = tyCons t
         tC _                   = []
tyCons (TCon c)                 = [c]
tyCons (TVar _)                 = []
tyCons (TAp t1 t2)              = nub (tyCons t1 ++ tyCons t2)
tyCons (TSub t1 t2)             = nub (tyCons t1 ++ tyCons t2)
tyCons TWild                    = []
tyCons (TList t)                = tyCons t
tyCons (TTup ts)                = nub (concatMap tyCons ts)
tyCons (TFun ts t)              = nub (concatMap tyCons (t : ts))

-- Substitution --------------------------------------------------------------

instance Subst Bind Name Exp where
    subst s (BSig xs t)         = BSig xs t
    subst s (BEqn lhs rhs)      = BEqn lhs (subst s rhs)


instance Subst Exp Name Exp where
    subst s (EVar x)            = case lookup x s of
                                    Just e  -> e
                                    Nothing -> EVar x
    subst s (EAp e e')          = EAp (subst s e) (subst s e')
    subst s (ECon c)            = ECon c
    subst s (ELit l)            = ELit l
    subst s (ETup es)           = ETup (subst s es)
    subst s (EList es)          = EList (subst s es)
    subst s (EWild)             = EWild
    subst s (ESig e t)          = ESig (subst s e) t
    subst s (ELam ps e)         = ELam ps (subst s e)
    subst s (ELet bs e)         = ELet (subst s bs) (subst s e)
    subst s (ECase e alts)      = ECase (subst s e) (subst s alts)
    subst s (ERec m fs)         = ERec m (subst s fs)
    subst s (EBStruct c ls bs)  = EBStruct c ls (subst s bs)
    subst s (EIf e1 e2 e3)      = EIf (subst s e1) (subst s e2) (subst s e3)
    subst s (ENeg e)            = ENeg (subst s e)
    subst s (ESeq e1 Nothing e2)  = ESeq (subst s e1) Nothing (subst s e2)
    subst s (ESeq e1 (Just e) e2) = ESeq (subst s e1) (Just (subst s e)) (subst s e2)
    subst s (EComp e qs)        = EComp (subst s e) (subst s qs)
    subst s (ESectR e op)       = ESectR (subst s e) op
    subst s (ESectL op e)       = ESectL op (subst s e)
    subst s (ESelect e l)       = ESelect (subst s e) l
    subst s (ESel l)            = ESel l
    subst s (EDo v t st)        = EDo v t (subst s st)
    subst s (ETempl v t st)     = ETempl v t (subst s st) 
    subst s (EAct v st)         = EAct v (subst s st)
    subst s (EReq v st)         = EReq v (subst s st)
    subst s (EAfter e e')       = EAfter (subst s e) (subst s e')
    subst s (EBefore e e')      = EBefore (subst s e) (subst s e')


instance Subst Field Name Exp where
    subst s (Field l e)         = Field l (subst s e)


instance Subst a Name Exp => Subst (Rhs a) Name Exp where
    subst s (RExp e)            = RExp (subst s e)
    subst s (RGrd gs)           = RGrd (subst s gs)
    subst s (RWhere rhs bs)     = RWhere (subst s rhs) (subst s bs)


instance Subst a Name Exp => Subst (GExp a) Name Exp where
    subst s (GExp qs e)         = GExp (subst s qs) (subst s e)

            
instance Subst a Name Exp => Subst (Alt a) Name Exp where
    subst s (Alt p rhs)         = Alt p (subst s rhs)


instance Subst Qual Name Exp where
    subst s (QExp e)            = QExp (subst s e)
    subst s (QGen p e)          = QGen p (subst s e)
    subst s (QLet bs)           = QLet (subst s bs)


            
instance Subst Stmt Name Exp where
    subst s (SExp e)            = SExp (subst s e)
    subst s (SRet e)            = SRet (subst s e)
    subst s (SGen p e)          = SGen p (subst s e)
    subst s (SBind bs)          = SBind (subst s bs)
    subst s (SAss p e)          = SAss p (subst s e)
    subst s (SForall qs st)     = SForall (subst s qs) (subst s st)
    subst s (SIf e st)          = SIf (subst s e) (subst s st)
    subst s (SElsif e st)       = SElsif (subst s e) (subst s st)
    subst s (SElse st)          = SElse (subst s st)
    subst s (SCase e alts)      = SCase (subst s e) (subst s alts)


instance Subst Type Name Type where
    subst s (TQual t ps)        = TQual (subst s t) (subst s ps)
    subst s (TCon c)            = TCon c
    subst s (TVar a)            = case lookup a s of
                                    Just t  -> t
                                    Nothing -> TVar a
    subst s (TAp t1 t2)         = TAp (subst s t1) (subst s t2)
    subst s (TSub t1 t2)        = TSub (subst s t1) (subst s t2)
    subst s TWild               = TWild
    subst s (TList t)           = TList (subst s t)
    subst s (TTup ts)           = TTup (subst s ts)
    subst s (TFun ts t)         = TFun (subst s ts) (subst s t)

instance Subst Pred Name Type where
    subst s (PType t)           = PType (subst s t)
    subst s p                   = p

-- Printing ==================================================================

-- Modules -------------------------------------------------------------------

instance Pr Module where
    pr (Module c is ds ps)      = text "module" <+> prId c <+> text "where"
                                  $$ vpr is $$ vpr ds 
                                  $$ text "private" $$ vpr ps

instance Pr Import where
   pr (Import True n)           = text "import" <+> prId n
   pr (Import False n)          = text "use" <+> prId n

-- Declarations --------------------------------------------------------------

instance Pr Decl where
    pr (DKSig c k)              = prId c <+> text "::" <+> pr k
    pr (DType c vs t)           = text "type" <+> prId c <+> hsep (map prId vs) 
                                  <+> equals <+> pr t
    pr (DData c vs subs cs)     = text "data" <+> prId c <+> hsep (map prId vs) 
                                  <+> prSubs subs <+> prCons cs
    pr (DRec isC c vs sups ss)  = text kwd <+> prId c <+> hsep (map prId vs) 
                                  <+> prSups sups <+> prEq ss $$ prSigs ss
      where kwd                 = if isC then "typeclass" else "struct"
--    pr (DInst t bs)             = text "instance" <+> pr t <+> text "=" $$ nest 4 (vpr bs)
    pr (DPSig v t)              = text "instance" <+> prId v <+> text "::" <+> pr t
    pr (DDefault ts)            = text "default" <+> hpr ',' ts
    pr (DInstance ns)           = text "instance" <+> hpr ',' ns 
    pr (DTClass ns)             = text "typeclass" <+> hpr ',' ns 
    pr (DBind bs)               = vpr bs

prPreds []                      = empty
prPreds ps                      = text " \\\\" <+> hpr ',' ps

prEq []                         = empty
prEq bs                         = text "where"

prSigs ss                       = nest 4 (vpr ss)

-- Sub/supertypes -----------------------------------------------------------

prSups []                       = empty
prSups ts                       = char '<' <+> hpr ',' ts

prSubs []                       = empty
prSubs ts                       = char '>' <+> hpr ',' ts
    

-- Constructors and contexts -----------------------------------------------


instance Pr Constr where
  pr (Constr c ts ps)           = prId c <+> hsep (map (prn 3) ts) <> prPreds ps

prCons []                       = empty
prCons (c:cs)                   = vcat (char '=' <+> pr c : map ((char '|' <+>) . pr) cs)



-- Signatures ------------------------------------------------------------

instance Pr Sig where
    pr (Sig vs qt)              = hcat (punctuate comma (map prId vs)) <+> text "::" <+> pr qt
    
    
-- Predicates ------------------------------------------------------------

instance Pr Pred where
    pr (PType t)                = pr t
    pr (PKind v k)              = prId v <+> text "::" <+> pr k

-- Left hand sides ------------------------------------------------------

instance Pr Lhs where
   pr (LFun v ps)               = prId v <+> hsep (map (prn 13) ps)
   pr (LPat p)                  = pr p

{-
-- Patterns --------------------------------------------------------------

instance Pr Pat where

    prn 0 (PCon c ps)           = prId c <+> hsep (map (prn 13) ps) 
    prn 0 p                     = prn 13 p

    prn 13 (PVar v)             = prId v
    prn 13 (PLit l)             = pr l
    prn 13 (PTup ps)            = parens (hpr ',' ps)
    prn 13 (PList ps)           = brackets (hpr ',' ps)
    prn 13 p                    = parens (pr p)

    prn n p                     = prn 13 p
-}

-- Types -----------------------------------------------------------------

instance Pr Type where
    prn 0 (TQual t ps)          = prn 1 t <> prPreds ps
    prn 0 t                     = prn 1 t

    prn 1 (TFun ts t)           = prArgs ts <+> prn 2 t
      where prArgs []           = empty
            prArgs (t:ts)       = prn 2 t <+> text "->" <+> prArgs ts
    prn 1 (TSub t t')           = prn 2 t <+> text "<" <+> prn 2 t'
    prn 1 t                     = prn 2 t

    prn 2 (TAp t t')            = prn 2 t <+> prn 3 t'
    prn 2 t                     = prn 3 t
        
    prn 3 (TCon c)              = prId c
    prn 3 (TVar v)              = prId v
    prn 3 (TWild)               = text "_"
    prn 3 (TList t)             = brackets (pr t)
    prn 3 (TTup ts)             = parens (hpr ',' ts)
    prn 3 t                     = parens (prn 0 t)

-- Bindings ----------------------------------------------------------------

instance Pr Bind where
    pr (BSig vs qt)             = hcat (punctuate comma (map prId vs)) <+> text "::" <+> pr qt
    pr (BEqn p (RExp e))        = pr p <+> equals <+> pr e
    pr (BEqn p rhs)             = pr p $$ nest 2 (prRhs equals rhs)

prRhs eq (RExp e)               = eq <+> pr e
prRhs eq (RGrd gs)              = vcat (map (prGuard eq) gs)
prRhs eq (RWhere rhs bs)        = prRhs eq rhs $$ text "where" $$ nest 4 (vpr bs)

prGuard eq (GExp qs e)          = char '|' <+> hpr ',' qs <+> eq <+> pr e


-- Expressions -------------------------------------------------------------

instance Pr Exp where
    prn 0 (ELam ps e)           = sep [char '\\' <> hsep (map (prn 13) ps) <+> text "->", pr e]
    prn 0 (ELet bs e)           = text "let" <+> vpr bs $$ text "in" <+> pr e
    prn 0 (EIf e e1 e2)         = text "if" <+> pr e $$
                                    nest 3 (text "then" <+> pr e1 $$
                                            text "else" <+> pr e2)
    prn 0 (ECase e alts)        = text "case" <+> pr e <+> text "of" $$ nest 2 (vpr alts)
    prn 0 (EDo v t ss)          = text "do"<>prN v <+> vpr ss 
    prn 0 (ETempl v t ss)       = text "class"<>prN v $$ nest 4 (vpr ss)
    prn 0 (EAct v ss)           = text "action"<>prN v $$ nest 4 (vpr ss) 
    prn 0 (EReq v ss)           = text "request"<>prN v $$ nest 4 (vpr ss) 
    prn 0 (EAfter e e')         = text "after" <+> prn 12 e <+> pr e'
    prn 0 (EBefore e e')        = text "before" <+> prn 12 e <+> pr e'
    prn 0 e                     = prn 1 e

    prn 11 (EAp e e')           = prn 11 e <+> prn 12 e'
    prn 11 e                    = prn 12 e
        
    prn 12 (ESelect e l)        = prn 12 e <> text "." <> prId l
    prn 12 e                    = prn 13 e
        
    prn 13 (EVar v)             = prId v
    prn 13 (ECon c)             = prId c
    prn 13 (ESel l)             = parens (text "." <> prId l)
    prn 13 (EWild)              = text "_"
    prn 13 (ELit l)             = pr l
    prn 13 (ERec Nothing fs)    = text "{" <+> hpr ',' fs <+> text "}"
    prn 13 (ERec (Just(c,b)) fs)= prId c <+> text "{" <+> hpr ',' fs <+> (if b then empty else text "..") <+> text "}"
    prn 13 (EBStruct _ _ bs)    = text "struct" $$ nest 4 (vpr bs)
    prn 13 (ENeg e)             = text "-" <+> prn 0 e
    prn 13 (ESig e qt)          = parens (pr e <+> text "::" <+> pr qt)
    prn 13 (ETup es)            = parens (hpr ',' es)
    prn 13 (ESectR e op)        = parens (pr e <> prOp op)
    prn 13 (ESectL op e)        = parens (prOp op <> pr e)
    prn 13 (EList es)           = brackets (hpr ',' es)
    prn 13 (ESeq e Nothing to) 
                                = brackets (pr e <> text ".." <> pr to)
    prn 13 (ESeq e (Just by) to) 
                                = brackets (pr e <> comma <> pr by <> text ".." <> pr to)
    prn 13 (EComp e qs)         = brackets (empty <+> pr e <+> char '|' <+> hpr ',' qs)
    prn 13 e                    = parens (prn 0 e)

    prn n e                     = prn 11 e
   
prN (Just v) = text "@" <> pr v
prN Nothing = empty 
instance Pr Field where
    pr (Field l e)              = prId l <+> equals <+> pr e
    
instance Pr a => Pr (Alt a) where
    pr (Alt p (RExp e))         = pr p <+> text "->" <+> pr e
    pr (Alt p rhs)              = pr p <+> prRhs (text "->") rhs

instance Pr Qual where
    pr (QExp e)                 = pr e
    pr (QGen p e)               = pr p <+> text "<-" <+> pr e
    pr (QLet bs)                = text "let" <+> hpr ';' bs

-- Statements --------------------------------------------------------------

instance Pr [Stmt] where
    pr ss                       = vpr ss

instance Pr Stmt where
    pr (SExp e)                 = pr e
    pr (SRet e)                 = text "result" <+> pr e
    pr (SGen p e)               = pr p <+> text "<-" <+> pr e
    pr (SBind bs)               = vpr bs
    pr (SAss p e)               = pr p <+> text ":=" <+> pr e
    pr (SIf e ss)               = text "if" <+> pr e <+> text "then" $$ nest 4 (pr ss)
    pr (SElsif e ss)            = text "elsif" <+> pr e <+> text "then" $$ nest 4 (pr ss)
    pr (SElse ss)               = text "else" $$ nest 4 (pr ss)
    pr (SForall qs ss)          = text "forall" <+> hpr ',' qs <+> text "do" $$ nest 4 (pr ss)
    pr (SCase e alts)           = text "case" <+> pr e <+> text "of" $$ nest 4 (vpr alts)


-- Free variables ------------------------------------------------------------

instance Ids Bind where
    idents (BEqn (LFun v ps) rh)= idents rh \\ (v : idents ps)
    idents (BEqn (LPat p) rh)   = idents rh \\ idents p 
    idents (BSig _ _)           = []

instance Ids Exp where
    idents (EVar v)             = [v]
    idents (EAp e e')           = idents e ++ idents e'
    idents (ETup es)            = idents es
    idents (EList es)           = idents es
    idents (ESig e _)           = idents e
    idents (ERec _  fs)         = idents fs
    idents (EBStruct _ _ bs)    = idents bs
    idents (ELam ps e)          = idents e \\ idents ps
    idents (ELet bs e)          = idents bs ++ (idents e \\ bvars bs)
    idents (ECase e as)         = idents e ++ idents as
    idents (EIf b t e)          = idents b ++ idents t ++ idents e
    idents (ENeg e)             = idents e
    idents (ESeq f Nothing t)   = idents f ++ idents t
    idents (ESeq f (Just s) t)  = idents f ++ idents s ++ idents t
    idents (EComp e qs)         = (idents e \\ bvars qs) ++ identQuals qs
    idents (ESectR e v)         = v : idents e
    idents (ESectL v e)         = v : idents e
    idents (ESelect e _)        = idents e
    idents (EDo _ _ ss)         = identStmts ss
    idents (ETempl _ _ ss)      = identStmts ss
    idents (EAct _ ss)          = identStmts ss 
    idents (EReq _ ss)          = identStmts ss 
    idents (EAfter e e')        = idents e ++ idents e'
    idents (EBefore e e')       = idents e ++ idents e'
    idents _                    = []

instance Ids Field where
    idents (Field _ e)          = idents e
    
instance Ids (Rhs Exp) where
    idents (RExp a)             = idents a
    idents (RGrd gs)            = idents gs
    idents (RWhere a bs)        = idents bs ++ (idents a \\ bvars bs)

instance Ids (GExp Exp) where
    idents (GExp qs a)          = identQuals qs ++ idents a
    
instance Ids (Alt Exp) where
    idents (Alt p a)            = idents a \\ idents p     

instance Ids (Rhs [Stmt]) where
    idents (RExp a)             = identStmts a
    idents (RGrd gs)            = idents gs
    idents (RWhere a bs)        = idents bs ++ (idents a \\ bvars bs)

instance Ids (GExp [Stmt]) where
    idents (GExp qs a)          = identQuals qs ++ identStmts a
    
instance Ids (Alt [Stmt]) where
    idents (Alt p a)            = idents a \\ idents p     


identQuals []                   = []
identQuals (QExp e : qs)        = idents e ++ identQuals qs
identQuals (QGen p e : qs)      = idents e ++ (identQuals qs \\ pvars p)
identQuals (QLet bs : qs)       = idents bs ++ (identQuals qs \\ bvars bs)


identStmts []                   = []
identStmts (SExp e : ss)        = idents e ++ identStmts ss
identStmts (SRet e : ss)        = idents e ++ identStmts ss
identStmts (SGen p e : ss)      = idents e ++ (identStmts ss \\ pvars p)
identStmts (SBind bs : ss)      = identSBind bs ss
identStmts (SAss p e : ss)      = idents e ++ (identStmts ss \\ pvars p)
identStmts (SForall qs ss' : ss)= identQuals qs ++ (identStmts ss' \\ bvars qs) ++ identStmts ss
identStmts (SIf e ss' : ss)     = idents e ++ identStmts ss' ++ identStmts ss
identStmts (SElsif e ss' : ss)  = idents e ++ identStmts ss' ++ identStmts ss
identStmts (SElse ss' : ss)     = identStmts ss' ++ identStmts ss
identStmts (SCase e as : ss)    = idents e ++ idents as ++ identStmts ss

identSBind bs (SBind bs' : ss ) = identSBind (bs++bs') ss
identSBind bs ss                = idents bs ++ (identStmts ss \\ bvars bs)


pvars p                         = evars p

assignedVars ss                 = concat [ pvars p | SAss p _ <- ss ]


-- Bound variables ----------------------------------------------------------

instance BVars [Bind] where
    bvars []                            = []
    bvars (BEqn (LPat p) _ : bs)        = pvars p ++ bvars bs
    bvars (BEqn (LFun v _) _ : bs)      = bvars' v bs
      where bvars' v (BEqn (LFun v' _) _ : bs)
              | v == v'                 = bvars' v bs
              | otherwise               = v : bvars' v' bs
            bvars' v bs                 = v : bvars bs
    bvars (_ : bs)                      = bvars bs

instance BVars [Field] where
    bvars bs                            = [ s | Field s e <- bs ]

instance BVars [Qual] where
    bvars []                            = []
    bvars (QGen p _ : qs)               = pvars p ++ bvars qs
    bvars (QLet bs : qs)                = bvars bs ++ bvars qs
    bvars (_ : qs)                      = bvars qs

instance BVars [Stmt] where
    bvars []                            = []
    bvars (SGen p e : ss)               = pvars p ++ bvars ss
    bvars (SBind bs : ss)               = bvars bs ++ bvars ss
    bvars (_ : ss)                      = bvars ss
  

instance BVars Lhs where
    bvars (LFun v ps)           = pvars ps
    bvars (LPat p)              = []

instance BVars [Pred] where
    bvars []                    = []
    bvars (PKind v k : ps)      = v : bvars ps
    bvars (PType (TVar v) : ps) = v : bvars ps
    bvars (p : ps)              = bvars ps


-- Free type variables -------------------------------------------------------

instance Ids Type where
  idents (TQual t ps)           = (idents t ++ idents ps) \\ bvars ps
  idents (TCon c)               = [c]
  idents (TVar v)               = [v]
  idents (TAp t t')             = idents t ++ idents t'
  idents (TSub t t')            = idents t ++ idents t'
  idents (TWild)                = []
  idents (TList t)              = idents t
  idents (TTup ts)              = concatMap idents ts
  idents (TFun t t')            = idents t ++ idents t'


instance Ids Pred where
  idents (PType (TVar v))       = []
  idents (PType t)              = idents t
  idents (PKind v k)            = []


-- PosInfo -------------------------------------------------------------------

instance HasPos Type where
  posInfo (TQual t ps)          = between (posInfo t) (posInfo ps)
  posInfo (TCon n)              = posInfo n
  posInfo (TVar n)              = posInfo n 
  posInfo (TAp t t')            = between (posInfo t) (posInfo t')
  posInfo (TSub t t')           = between (posInfo t) (posInfo t')
  posInfo TWild                 = Unknown
  posInfo (TList t)             = posInfo t 
  posInfo (TTup ts)             = posInfo ts
  posInfo (TFun ts t)           = between (posInfo ts) (posInfo t)

instance HasPos Pred where
  posInfo (PType t)              = posInfo t
  posInfo (PKind n k)            = posInfo n

instance HasPos Exp where
  posInfo (EVar n)              = posInfo n
  posInfo (ECon c)              = posInfo c
  posInfo (EAp e e')            = between (posInfo e) (posInfo e')
  posInfo (ESel n)              = posInfo n
  posInfo (ETup es)             = posInfo es
  posInfo (EList es)            = posInfo es
  posInfo (ESig e t)            = between (posInfo e) (posInfo t)
  posInfo (ERec m fs)           = between (posInfo m) (posInfo fs)
  posInfo (EBStruct c _ bs)     = between (posInfo c) (posInfo bs)
  posInfo (ELam ps e)           = between (posInfo ps) (posInfo e)
  posInfo (ELet bs e)           = between (posInfo bs) (posInfo e)
  posInfo (ECase e as)          = between (posInfo e) (posInfo as)
  posInfo (EIf e t f)           = posInfo [e,t,f]
  posInfo (ENeg e)              = posInfo e
  posInfo (ESeq e1 m e2)        = foldr1 between [posInfo e1, posInfo m, posInfo e2]
  posInfo (EComp e qs)          = between (posInfo e) (posInfo qs)
  posInfo (ESectR e n)          = between (posInfo e) (posInfo n)
  posInfo (ESectL n e)          = between (posInfo n) (posInfo e)
  posInfo (ESelect e n)         = between (posInfo e) (posInfo n)
  posInfo (EDo n t ss)          = between (posInfo n) (posInfo ss)
  posInfo (ETempl n t ss)       = between (posInfo n) (posInfo ss)
  posInfo (EAct n ss)           = between (posInfo n) (posInfo ss)
  posInfo (EReq n ss)           = between (posInfo n) (posInfo ss)
  posInfo (EAfter e e')         = between (posInfo e) (posInfo e')
  posInfo (EBefore e e')        = between (posInfo e) (posInfo e')
  posInfo (ELit l)              = posInfo l
  posInfo _                     = Unknown

instance HasPos Field where
  posInfo (Field n e)           = between (posInfo n) (posInfo e)

instance HasPos a => HasPos (Rhs a) where
  posInfo (RExp a)              = posInfo a
  posInfo (RGrd gs)             = posInfo gs
  posInfo (RWhere r bs)         = between (posInfo r) (posInfo bs)
 
instance HasPos a => HasPos (GExp a) where
  posInfo (GExp qs a)           = between (posInfo qs) (posInfo a)

instance HasPos a => HasPos (Alt a) where
  posInfo (Alt p r)             = between (posInfo p) (posInfo r)

instance HasPos Qual where
  posInfo (QExp e)              = posInfo e
  posInfo (QGen p e)            = between (posInfo p) (posInfo e)
  posInfo (QLet bs)             = posInfo bs

instance HasPos Stmt where
  posInfo (SExp e)              = posInfo e
  posInfo (SRet e)              = posInfo e
  posInfo (SGen p e)            = between (posInfo p) (posInfo e)
  posInfo (SBind b)             = posInfo b
  posInfo (SAss p e)            = between (posInfo p) (posInfo e)
  posInfo (SForall qs ss)       = between (posInfo qs) (posInfo ss)
  posInfo (SIf e ss)            = between (posInfo e) (posInfo ss)
  posInfo (SElsif e ss)         = between (posInfo e) (posInfo ss)
  posInfo (SElse ss)            = posInfo ss
  posInfo (SCase e as)          = between (posInfo e) (posInfo as)

instance HasPos Bind where
  posInfo (BSig ns t)           = posInfo ns
  posInfo (BEqn l r)            = between (posInfo l) (posInfo r)

instance HasPos Lhs where
  posInfo (LFun n ps)           = between (posInfo n) (posInfo ps)
  posInfo (LPat p)              = posInfo p

-- Binary --------------------------------------------------------------------

instance Binary Module where
  put (Module a b c d) = put a >> put b >> put c >> put d
  get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return (Module a b c d)

instance Binary Import where
  put (Import a b) = put a >> put b
  get = get >>= \a -> get >>= \b -> return (Import a b)

instance Binary Decl where
  put (DKSig a b) = putWord8 0 >> put a >> put b
  put (DData a b c d) = putWord8 1 >> put a >> put b >> put c >> put d
  put (DRec a b c d e) = putWord8 2 >> put a >> put b >> put c >> put d >> put e
  put (DType a b c) = putWord8 3 >> put a >> put b >> put c
--  put (DInst a b) = putWord8 4 >> put a >> put b
  put (DPSig a b) = putWord8 4 >> put a >> put b
  put (DDefault a) = putWord8 5 >> put a
  put (DInstance a) = putWord8 6 >> put a
  put (DTClass a) = putWord8 7 >> put a
  put (DBind a) = putWord8 8 >> put a
  get = do
    tag_ <- getWord8
    case tag_ of
      0 -> get >>= \a -> get >>= \b -> return (DKSig a b)
      1 -> get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return (DData a b c d)
      2 -> get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> get >>= \e -> return (DRec a b c d e)
      3 -> get >>= \a -> get >>= \b -> get >>= \c -> return (DType a b c)
--      4 -> get >>= \a -> get >>= \b -> return (DInst a b)
      4 -> get >>= \a -> get >>= \b -> return (DPSig a b)
      5 -> get >>= \a -> return (DDefault a)
      6 -> get >>= \a -> return (DInstance a)
      7 -> get >>= \a -> return (DTClass a)
      8 -> get >>= \a -> return (DBind a)
      _ -> fail "no parse"


instance Binary Constr where
  put (Constr a b c) = put a >> put b >> put c
  get = get >>= \a -> get >>= \b -> get >>= \c -> return (Constr a b c)

instance Binary Sig where
  put (Sig a b) = put a >> put b
  get = get >>= \a -> get >>= \b -> return (Sig a b)

instance Binary Bind where
  put (BSig a b) = putWord8 0 >> put a >> put b
  put (BEqn a b) = putWord8 1 >> put a >> put b
  get = do
    tag_ <- getWord8
    case tag_ of
      0 -> get >>= \a -> get >>= \b -> return (BSig a b)
      1 -> get >>= \a -> get >>= \b -> return (BEqn a b)
      _ -> fail "no parse"

instance Binary Type where
  put (TQual a b) = putWord8 0 >> put a >> put b
  put (TCon a) = putWord8 1 >> put a
  put (TVar a) = putWord8 2 >> put a
  put (TAp a b) = putWord8 3 >> put a >> put b
  put (TSub a b) = putWord8 4 >> put a >> put b
  put TWild = putWord8 5
  put (TList a) = putWord8 6 >> put a
  put (TTup a) = putWord8 7 >> put a
  put (TFun a b) = putWord8 8 >> put a >> put b
  get = do
    tag_ <- getWord8
    case tag_ of
      0 -> get >>= \a -> get >>= \b -> return (TQual a b)
      1 -> get >>= \a -> return (TCon a)
      2 -> get >>= \a -> return (TVar a)
      3 -> get >>= \a -> get >>= \b -> return (TAp a b)
      4 -> get >>= \a -> get >>= \b -> return (TSub a b)
      5 -> return TWild
      6 -> get >>= \a -> return (TList a)
      7 -> get >>= \a -> return (TTup a)
      8 -> get >>= \a -> get >>= \b -> return (TFun a b)
      _ -> fail "no parse"

instance Binary Pred where
  put (PType a) = putWord8 0 >> put a
  put (PKind a b) = putWord8 1 >> put a >> put b
  get = do
    tag_ <- getWord8
    case tag_ of
      0 -> get >>= \a -> return (PType a)
      1 -> get >>= \a -> get >>= \b -> return (PKind a b)
      _ -> fail "no parse"

instance Binary Lhs where
  put (LFun a b) = putWord8 0 >> put a >> put b
  put (LPat a) = putWord8 1 >> put a
  get = do
    tag_ <- getWord8
    case tag_ of
      0 -> get >>= \a -> get >>= \b -> return (LFun a b)
      1 -> get >>= \a -> return (LPat a)
      _ -> fail "no parse"

instance Binary Exp where
  put (EVar a) = putWord8 0 >> put a
  put (EAp a b) = putWord8 1 >> put a >> put b
  put (ECon a) = putWord8 2 >> put a
  put (ESel a) = putWord8 3 >> put a
  put (ELit a) = putWord8 4 >> put a
  put (ETup a) = putWord8 5 >> put a
  put (EList a) = putWord8 6 >> put a
  put EWild = putWord8 7
  put (ESig a b) = putWord8 8 >> put a >> put b
  put (ERec a b) = putWord8 9 >> put a >> put b
  put (ELam a b) = putWord8 10 >> put a >> put b
  put (ELet a b) = putWord8 11 >> put a >> put b
  put (ECase a b) = putWord8 12 >> put a >> put b
  put (EIf a b c) = putWord8 13 >> put a >> put b >> put c
  put (ENeg a) = putWord8 14 >> put a
  put (ESeq a b c) = putWord8 15 >> put a >> put b >> put c
  put (EComp a b) = putWord8 16 >> put a >> put b
  put (ESectR a b) = putWord8 17 >> put a >> put b
  put (ESectL a b) = putWord8 18 >> put a >> put b
  put (ESelect a b) = putWord8 19 >> put a >> put b
  put (EDo a b c) = putWord8 21 >> put a >> put b >> put c
  put (ETempl a b c) = putWord8 22 >> put a >> put b >> put c
  put (EAct a b) = putWord8 23 >> put a >> put b
  put (EReq a b) = putWord8 24 >> put a >> put b
  put (EAfter a b) = putWord8 25 >> put a >> put b
  put (EBefore a b) = putWord8 26 >> put a >> put b
  put (EBStruct a b c) = putWord8 27 >> put a >> put b >> put c
  get = do
    tag_ <- getWord8
    case tag_ of
      0 -> get >>= \a -> return (EVar a)
      1 -> get >>= \a -> get >>= \b -> return (EAp a b)
      2 -> get >>= \a -> return (ECon a)
      3 -> get >>= \a -> return (ESel a)
      4 -> get >>= \a -> return (ELit a)
      5 -> get >>= \a -> return (ETup a)
      6 -> get >>= \a -> return (EList a)
      7 -> return EWild
      8 -> get >>= \a -> get >>= \b -> return (ESig a b)
      9 -> get >>= \a -> get >>= \b -> return (ERec a b)
      10 -> get >>= \a -> get >>= \b -> return (ELam a b)
      11 -> get >>= \a -> get >>= \b -> return (ELet a b)
      12 -> get >>= \a -> get >>= \b -> return (ECase a b)
      13 -> get >>= \a -> get >>= \b -> get >>= \c -> return (EIf a b c)
      14 -> get >>= \a -> return (ENeg a)
      15 -> get >>= \a -> get >>= \b -> get >>= \c -> return (ESeq a b c)
      16 -> get >>= \a -> get >>= \b -> return (EComp a b)
      17 -> get >>= \a -> get >>= \b -> return (ESectR a b)
      18 -> get >>= \a -> get >>= \b -> return (ESectL a b)
      19 -> get >>= \a -> get >>= \b -> return (ESelect a b)
      21 -> get >>= \a -> get >>= \b -> get >>= \c -> return (EDo a b c)
      22 -> get >>= \a -> get >>= \b -> get >>= \c -> return (ETempl a b c)
      23 -> get >>= \a -> get >>= \b -> return (EAct a b)
      24 -> get >>= \a -> get >>= \b -> return (EReq a b)
      25 -> get >>= \a -> get >>= \b -> return (EAfter a b)
      26 -> get >>= \a -> get >>= \b -> return (EBefore a b)
      27 -> get >>= \a -> get >>= \b -> get >>= \c -> return (EBStruct a b c)
      _ -> fail "no parse"

instance Binary Field where
  put (Field a b) = put a >> put b
  get = get >>= \a -> get >>= \b -> return (Field a b)

instance (Binary a) => Binary (Rhs a) where
  put (RExp a) = putWord8 0 >> put a
  put (RGrd a) = putWord8 1 >> put a
  put (RWhere a b) = putWord8 2 >> put a >> put b
  get = do
    tag_ <- getWord8
    case tag_ of
      0 -> get >>= \a -> return (RExp a)
      1 -> get >>= \a -> return (RGrd a)
      2 -> get >>= \a -> get >>= \b -> return (RWhere a b)
      _ -> fail "no parse"

instance (Binary a) => Binary (GExp a) where
  put (GExp a b) = put a >> put b
  get = get >>= \a -> get >>= \b -> return (GExp a b)

instance (Binary a) => Binary (Alt a) where
  put (Alt a b) = put a >> put b
  get = get >>= \a -> get >>= \b -> return (Alt a b)

instance Binary Qual where
  put (QExp a) = putWord8 0 >> put a
  put (QGen a b) = putWord8 1 >> put a >> put b
  put (QLet a) = putWord8 2 >> put a
  get = do
    tag_ <- getWord8
    case tag_ of
      0 -> get >>= \a -> return (QExp a)
      1 -> get >>= \a -> get >>= \b -> return (QGen a b)
      2 -> get >>= \a -> return (QLet a)
      _ -> fail "no parse"

instance Binary Stmt where
  put (SExp a) = putWord8 0 >> put a
  put (SRet a) = putWord8 1 >> put a
  put (SGen a b) = putWord8 2 >> put a >> put b
  put (SBind a) = putWord8 3 >> put a
  put (SAss a b) = putWord8 4 >> put a >> put b
  put (SForall a b) = putWord8 5 >> put a >> put b
  put (SIf a b) = putWord8 7 >> put a >> put b
  put (SElsif a b) = putWord8 8 >> put a >> put b
  put (SElse a) = putWord8 9 >> put a
  put (SCase a b) = putWord8 10 >> put a >> put b
  get = do
    tag_ <- getWord8
    case tag_ of
      0 -> get >>= \a -> return (SExp a)
      1 -> get >>= \a -> return (SRet a)
      2 -> get >>= \a -> get >>= \b -> return (SGen a b)
      3 -> get >>= \a -> return (SBind a)
      4 -> get >>= \a -> get >>= \b -> return (SAss a b)
      5 -> get >>= \a -> get >>= \b -> return (SForall a b)
      7 -> get >>= \a -> get >>= \b -> return (SIf a b)
      8 -> get >>= \a -> get >>= \b -> return (SElsif a b)
      9 -> get >>= \a -> return (SElse a)
      10 -> get >>= \a -> get >>= \b -> return (SCase a b)
      _ -> fail "no parse"