AspectAG-0.2: examples/Main.hs

-----------------------------------------------------------------------------
--
-- Module      :  Main
-- Copyright   :
-- License     :  AllRightsReserved
--
-- Maintainer  :
-- Stability   :
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------

{-# LANGUAGE TemplateHaskell, EmptyDataDecls #-}

module Main where


import Language.Grammars.AspectAG
import Language.Grammars.AspectAG.Derive

import Data.HList.Label4
import Data.HList.TypeEqGeneric1
import Data.HList.TypeCastGeneric1

-- data DefinitionList
--    = DLCons { dlHd :: Definition, dlTl :: DefinitionList } | DLNil { dlNil :: () }


data Const
    =   ConstString String
    |   ConstInt    Int
    |   ConstChar   Char
    deriving(Show, Eq)

type WrapConst = Const
type StringList = [String]

$(typeList "EList" "Expression")
fromListEList = foldr ConsEList NilEList -- could be generated by typeList

data Definition
    =   Definition {
            dName       :: String
    ,       dArgs       :: StringList
    ,       dExpression :: Expression
    ,       dWhere      :: DefinitionList
    }  

type DefinitionList = [Definition]

data Expression
    =   Application { eFn :: Expression, eArgs :: EList }
    |   Atom { eAtom :: String }
    |   Lambda { eFormalArgs :: StringList, eBody :: Expression }
    |   Constant { eConst :: WrapConst }


$(deriveAG ''Definition)

$(attLabels ["xerror", "diLevel", "xerror2"])

{-
processChildList children = map (\ex -> sem_Expression (asp_xerror ()) ex emptyRecord) children

processArgs eArgs = do
    return $ foldr (\x l -> "o" : (x # xerror) ++ l) [] $ processChildList eArgs
-}

asp_xerrorD () = synAspect xerror (nt_Definition .*. nt_Expression .*. nt_EList .*. hNil)
        ((++)::[String] -> [String] -> [String])  ([]::[String])
        ( p_Application .*. p_Definition .*. p_Atom .*. p_Lambda .*. p_Constant .*. hNil ) $ -- use rule
        emptyRecord

-- could also be generated by typeList
asp_foldrEList f s = synAspect xerror (nt_EList .*. nt_Expression .*. hNil)
                f  s
                (p_ConsEList .*. p_NilEList .*. hNil)
                emptyRecord


asp_xerror () = asp_xerrorD () .+. asp_foldrEList ((\lhd ltl -> "o" : lhd ++ ltl)::[String] -> [String] -> [String]) ([]::[String])

asp_xerror2 () = synAspect xerror2 (nt_Definition .*. nt_Expression .*. nt_EList .*. hNil)
        ((++)::[String] -> [String] -> [String])  ([]::[String])
        ( p_Application .*. p_Atom .*. p_Lambda .*. p_Constant .*. p_ConsEList .*. p_NilEList .*. hNil ) $ -- use rule
        p_Definition .=. (def $ at lhs >>= \lhs -> do return [show $ lhs # diLevel ]) .*.
        emptyRecord

{-
asp_diLevel () = inhAspect diLevel ( nt_Expression .*. hNil ) ( p_Application .*. p_Lambda .*. hNil ) $
    p_Definition .=. (def $ at lhs >>= \lhs -> return $ (ch_dExpression .=. (lhs # diLevel) + 1) .*. emptyRecord)
    .*. emptyRecord
-}


ex :: Expression
ex = Application (Lambda ["foo"] (Atom "x")) $ fromListEList $ map (Constant . ConstInt) [2, 2, 5]

dd = Definition {
        dName = "bar"
    ,   dArgs = ["x", "y"]
    ,   dExpression = ex
    ,   dWhere = []
    }

sem1 = sem_Definition (asp_xerror  ()) dd (diLevel .=. 55 .*. emptyRecord) # xerror
sem2 = sem_Definition (asp_xerror2 ()) dd (diLevel .=. 55 .*. emptyRecord) # xerror2

sem3 = sem_Definition (asp_xerror () .+. asp_xerror2 ())  dd (diLevel .=. 55 .*. emptyRecord) # xerror2

main = print sem1 >> print sem2 >> print sem3