{-# 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