module Language.Grammars.ZipperAG.Examples.Algol68 where
import Data.Data
import Data.Generics.Zipper
import Data.Maybe
import Language.Grammars.ZipperAG
data Root = Root Its
deriving (Typeable, Show, Data)
data Its = ConsIts It Its
| NilIts
deriving (Show, Typeable, Data)
data It = Decl String
| Use String
| Block Its
deriving (Show, Typeable, Data)
constructor :: (Typeable a) => Zipper a -> String
constructor a = case ( getHole a :: Maybe Its ) of
Just (ConsIts _ _) -> "ConsIts"
Just (NilIts) -> "NilIts"
otherwise -> case ( getHole a :: Maybe It ) of
Just (Decl _) -> "Decl"
Just (Use _) -> "Use"
Just (Block _) -> "Block"
otherwise -> case ( getHole a :: Maybe Root) of
Just (Root _) -> "Root"
otherwise -> error "Naha, that production does not exist!"
value z = case (getHole z :: Maybe It) of
Just (Use x) -> x
Just (Decl x) -> x
dclo :: Zipper Root -> [(String, Int)]
dclo z = case (constructor z) of
"ConsIts" -> dclo $ z.$2
"NilIts" -> dcli z
"Use" -> dcli z
"Decl" -> (value z,lev z) : (dcli z)
"Block" -> dcli z
errs :: Zipper Root -> [String]
errs z = case (constructor z) of
"Root" -> errs $ z.$1
"NilIts" -> []
"ConsIts" -> (errs $ z.$1) ++ (errs $ z.$2)
"Use" -> mBIn (value z) (env z)
"Decl" -> mNBIn (value z,lev z) (dcli z)
"Block" -> errs $ z.$1
dcli :: Zipper Root -> [(String, Int)]
dcli z = case (constructor z) of
"Root" -> []
"NilIts" -> case (constructor $ parent z) of
"ConsIts" -> dclo $ (parent z).$1
"Block" -> env $ parent z
"Root" -> []
"ConsIts" -> case (constructor $ parent z) of
"ConsIts" -> dclo $ (parent z).$1
"Block" -> env $ parent z
"Root" -> []
"Block" -> dcli $ parent z
"Use" -> dcli $ parent z
"Decl" -> dcli $ parent z
lev :: Zipper Root -> Int
lev z = case (constructor z) of
"Root" -> 0
"NilIts" -> case (constructor $ parent z) of
"Block" -> (lev $ parent z) + 1
"ConsIts" -> lev $ parent z
"Root" -> 0
"ConsIts" -> case (constructor $ parent z) of
"Block" -> (lev $ parent z) + 1
"ConsIts" -> lev $ parent z
"Root" -> 0
"Block" -> lev $ parent z
"Use" -> lev $ parent z
"Decl" -> lev $ parent z
env :: Zipper Root -> [(String, Int)]
env z = case (constructor z) of
"NilIts" -> case (constructor $ parent z) of
"Block" -> dclo z
"ConsIts" -> env $ parent z
"Root" -> dclo z
"ConsIts" -> case (constructor $ parent z) of
"Block" -> dclo z
"ConsIts" -> env $ parent z
"Root" -> dclo z
"Block" -> env $ parent z
"Use" -> env $ parent z
"Decl" -> env $ parent z
"Root" -> dclo z
block = Block (ConsIts (Decl "x") (ConsIts (Use "y") (ConsIts (Use "w") (NilIts))))
program = ConsIts (Decl "y") (ConsIts (Decl "x") (ConsIts (block) (ConsIts (Decl "x") (ConsIts (Use "y") (NilIts)))))
mBIn name [] = [name]
mBIn name ((n,l):es) = if (n==name) then [] else mBIn name es
mNBIn tuple [] = []
mNBIn pair (pl:es) = if pair==pl then [fst pair] else mNBIn pair es
semantics t = errs $ toZipper $ Root t