module Scope2(TPtag(..),
              TPStag(..),
              Bind(..),
              Scope(..),
              prop,
              scopeD,
              scopeE,
              scopeT)
where

import Syntax
import List(find, nub, nubBy, (\\), sortBy, groupBy, union)
import Maybe
import SyntaxUtil(isTyVar, getTyName)

------------------------------------------------------------------
-- This module is supposed to capture the details of scoping in Haskell
-- The idea is you supply a bunch of functions with type:
--    pat -> env -> a
-- Since the [Decls] in Haskell are mutually recursive
-- one has to decide who should
-- to the environment which is passed to checkDs result function.
-- e.g. in scopeE for HsLet we say:
--    HsLet (ds,f) e -> 
--       let env2 = ext (Bdecls ds) env 
--       in  HsLet (f env2) (e env2)
-- note how we compute the new env, and pass it to both the ds and the f



data Scope v = Sc (Bind -> v -> v) (v -> v)

data TPtag 
 = ClassTag-- (Env e x)         -- expects (C v1 ... vn)
 | InstTag -- (Env [Int] Bool)  -- expects (C t1 ... tn)
 | SigTag  -- (e : typ)         -- Any type allowed 
 
data TPStag
 = TypeTPS  -- type tp = t
 | DataTPS  -- data tp = C ts | ... | Cn ts  --OR-- newtype tp = C t

data Bind 
 = Bpat SrcLoc HsPat
 | Bpats SrcLoc [ HsPat ]
 | Bdecls [ HsDecl ]
 | Bname SrcLoc HsName
 | Btypat TPtag HsType
 | Btypats TPStag [ HsType ]
 | Btyvar HsName

-----------------------------------------------
-- Whenever we have a list of binding things, like HsPat or typePat
-- we end up with a list of pairs. The first thing in the pair is a
-- binding thing, and the second is the result-producer. What we really
-- want is to build a list of things, and one big result-producer that
-- produces a list of results.

extPairs :: [(b,v->r)] -> ([b],v->[r])    

extPairs [] = ([],const [])
extPairs ((p,g):xs) = (p:ps,h)
   where (ps,g2) = extPairs xs
         h env = (g env) : (g2 env)

prop env f = f env

----------------------------------------    
scopeE :: 
   (Scope v) -> v -> 
   E (v -> e) (HsPat,v -> p) ([HsDecl],v -> ds) (v -> t) (v -> c) -> 
   E e p ds t c

scopeE (lib @ (Sc ext restrict)) env x =
  case x of
    HsLet (ds,f) e -> 
       let env2 = ext (Bdecls ds) env 
       in  HsLet (f env2) (e env2)
    HsLambda pairs e -> 
       let (ps,psf) = extPairs pairs 
           env2 = ext (Bpats loc0 ps) env
       in HsLambda (psf env) (e env2)
    HsCase e alts -> HsCase (e env) (map (scopeAlt lib env) alts)
    HsDo stmt -> HsDo (scopeStmt lib env stmt)
    HsListComp stmt -> HsListComp (scopeStmt lib env stmt)
    other -> mapE (prop env) (prop env . snd) (prop env . snd) (prop env) (prop env) other
                           
----------------------------------------
scopeStmt :: 
  (Scope v) -> v -> 
  HsStmt (v -> e) (HsPat,v -> p) ([HsDecl],v -> ds) ->
  HsStmt e p ds
  
scopeStmt (lib @ (Sc ext restrict)) env x =
  case x of 
   (HsGenerator (p,pf) e s) ->
      let env2 = ext (Bpat loc0 p) env 
      in HsGenerator (pf env) (e env2) (scopeStmt lib env2 s)
   (HsQualifier e s) -> HsQualifier (e env) (scopeStmt lib env s)
   (HsLetStmt (ds,dsf) s) ->
      let env2 = ext (Bdecls ds) env 
      in HsLetStmt (dsf env2) (scopeStmt lib env2 s)
   (HsLast e) -> HsLast (e env)   

----------------------------------------
scopeAlt :: 
   (Scope v) -> v -> 
   HsAlt (v -> e) (HsPat,v -> p) ([HsDecl],v -> ds) ->
   HsAlt e p ds

scopeAlt (Sc ext restrict) env (HsAlt s (p,pf) rhs (ds,dsf)) = 
    let env2 = ext (Bpat s p) env
        env3 = ext (Bdecls ds) env2
    in  (HsAlt s (pf env) (scopeRhs env3 rhs) (dsf env3))

-----------------------------------------
scopeRhs :: v -> HsRhs (v -> e) -> HsRhs e
scopeRhs env x = mapRhs (prop env) x


--------------------------------------------
scopeD :: 
    (Scope v) -> v -> 
    D (v -> e) (HsPat, v -> p) ([HsDecl], v -> ds) (v -> t) (v -> c) (HsType, v -> tp) -> 
    D e p ds t c tp 

scopeD (lib @ (Sc ext restrict)) env x =
  let scopConDecl env = mapConDecl (prop env) 
      extendWithTvs env tvs = foldr (\ nm v -> ext (Btyvar nm) v) env tvs
      scopMatch env (HsMatch loc nm pairs rhs (ds,df)) = 
        let (ps,psf) = extPairs pairs 
            env2 = ext (Bpats loc ps) env
            env3 = ext (Bdecls ds) (ext (Bname loc nm) env2)
        in HsMatch loc nm (psf env) (scopeRhs env3 rhs) (df env3)
  in
  case x of
    HsPatBind loc (p,pf) rhs (ds,dsf) ->
        let env1 = ext (Bpat loc p) env
            env2 = ext (Bdecls ds)  env1
        in HsPatBind loc (pf env) (scopeRhs env2 rhs) (dsf env2)
    HsFunBind loc matches -> HsFunBind loc (map (scopMatch env) matches)
    HsTypeDecl loc pairs tf -> 
        let (ts,tsf) = extPairs pairs 
            env2 = ext (Btypats TypeTPS ts) env
        in HsTypeDecl loc (tsf env) (tf env2)   
    HsNewTypeDecl loc contxtf pairs condecl derivs ->
        let (ts,tsf) = extPairs pairs 
            env2 = ext (Btypats DataTPS ts) env
            env3 = ext (Btypats TypeTPS ts ) (restrict env)
        in  HsNewTypeDecl loc (contxtf env3) (tsf env) (scopConDecl env2 condecl) derivs      
    HsDataDecl loc contxtf pairs condecls derivs ->
        let (ts,tsf) = extPairs pairs 
            env2 = ext (Btypats DataTPS ts) env
            env3 = ext (Btypats TypeTPS ts ) (restrict env)
        in  HsDataDecl loc (contxtf env3) (tsf env) (map (scopConDecl env2) condecls) derivs 
    HsClassDecl loc contxtf (tp,tpf) (ds,dsf) ->    
         let env1 = ext (Btypat ClassTag tp) (restrict env)
             env2 = ext (Btypat ClassTag tp) env
         in HsClassDecl loc (contxtf env1) (tpf env1) (dsf env2) 
    HsInstDecl loc contxtf (tp,tpf) (ds,dsf) ->    
         let env1 = ext (Btypat InstTag tp) (restrict env)
             env2 = ext (Btypat InstTag tp) env
         in HsInstDecl loc (contxtf env1) (tpf env1) (dsf env2) 
    HsTypeSig loc nms contxtf (tp, tpf)  ->
         let env1 = ext (Btypat SigTag tp) env
         in HsTypeSig loc nms (contxtf env1) (tpf env)
    z -> mapD (prop env) h h (prop env) (prop env) h z
         where h (x,f) = error "Binding case in scopeD not handled"      

--------------------------------------------------------------------------
-- Then for the type sub-language

scopeT :: v -> T (v -> t) -> T t
scopeT env t = mapT (\f -> f env) t