{-# LANGUAGE GADTs, EmptyDataDecls, ExistentialQuantification, ScopedTypeVariables, RankNTypes, DeriveDataTypeable, NoMonomorphismRestriction, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances, TypeSynonymInstances #-}

module Algol68 where

import Zipper 
import ZipperDemo
import Data.Data
import Prelude hiding (head, tail, zip)

p' = Prog [Decl "y", Decl "x", Block [Decl "y", Use "y", Use "w"], Decl "x", Use "y"]


type Env = [(String, Int)]
type Errors = [String]
    
down p = child p Prog

head l = move_left (child l cons)

tail l = child l cons

nested p = child p Block


semantics :: P -> [String]
semantics p = errs (zip p)

class Attributable l a r up where
    lev  :: Zipper l a r up -> Int
    dcli :: Zipper l a r up -> Env
    dclo :: Zipper l a r up -> Env
    env  :: Zipper l a r up -> Env  
    errs :: Zipper l a r up -> Errors

instance (Typeable l, Typeable r, Typeable up)
    => Attributable l P r up
    where lev  p = 0
          dcli p = []
          dclo p = dclo (down p)
          env  p = dclo (down p)
          errs p = errs (down p)


-- the current sequence of instructions descends from a value of type "P"
instance (Typeable l1, Typeable r1, Typeable up, Typeable r, Typeable l)
     => Attributable l1 Its r1 (Up l P r up)
    where lev  its = lev  $ parent its
          dcli its = dcli $ parent its
          dclo its = case (value its)
                of [] -> dcli its
                   _:_ -> dclo (tail its)
          env  its = env  $ parent its
          errs its = case (value its)
                of [] -> []
                   _:_ -> errs (head its) ++ errs (tail its)


-- the current sequence of instructions is a nested block
instance (Typeable l, Typeable r, Typeable up, Typeable r1, Typeable l1,
          Attributable l It r up) 
    => Attributable l1 Its r1 (Up l It r up)
    where lev  its = lev $ parent its
          dcli its = env (parent its) --dclo (parent its)
          env  its = dclo its
          dclo its = case (value its)
                of [] -> dcli its
                   _:_ -> dclo (tail its)
          errs its = case (value its)
                of [] -> []
                   _:_ -> (errs (head its)) ++ (errs (tail its))


-- the current sequence of instructions descends from a value of type "Its"
instance (Typeable up, Typeable r, Typeable l, Typeable r1, Typeable a, Typeable l1, 
          Attributable l Its r up,
          Attributable l1 a (Its -> r1) (Up l Its r up))
    => Attributable (l1->a) Its r1 (Up l Its r up)
    where lev  its = lev $ parent its
          dcli its = dclo (move_left its)
          dclo its = case (value its)
                of [] -> dcli its
                   _:_ -> dclo (tail its)
          env  its = env $ parent its
          errs its = case (value its)
                of [] -> []
                   _:_ -> (errs (head its)) ++ (errs (tail its))


instance (Typeable l1, Typeable r1, Typeable l, Typeable a, Typeable r, Typeable up,
          Attributable l a r up)
    => Attributable l1 It r1 (Up l a r up)
    where lev  it = case (value it)
                of Block _ -> 1 + lev (parent it)
                   _ -> lev (parent it)
          dcli it = dcli $ parent it
          dclo it = case (value it)
                of Decl x -> (x, lev it) : (dcli it)
                   otherwise -> dcli it
          env  it = env  $ parent it
          errs it = case (value it)
                of Block _ -> errs (nested it)
                   Decl  n -> mNBIn n (lev it) (dcli it)
                   Use   n -> mBIn n (env it)


{- Environment lookup functions -}

mBIn name e =
 case e of [] -> [name]
           (n,l):es -> if (n==name) 
                       then [] 
                       else mBIn name es

mNBIn name lev e =
 case e of [] -> [] 
           ((n,l):es) -> if (n, l)==(name,lev)
                         then [n] 
                         else mNBIn name lev es