6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmann{- |

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel HausmannModule : $Header$

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel HausmannCopyright : (c) K. L�ttich, C. Maeder and Uni Bremen 2002-2006

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel HausmannLicense : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmann

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel HausmannMaintainer : maeder@tzi.de

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel HausmannStability : provisional

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel HausmannPortability : portable

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmann

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmanngenerate ShATermConvertible instances

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmann-}

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmann

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmannmodule UserRulesHetCATS (hetcatsrules) where

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmann

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmannimport RuleUtils -- gives some examples

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmannimport Pretty

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmannimport List

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmann

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmannhetcatsrules :: [RuleDef]

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmannhetcatsrules = [ ("ShATermConvertible", shatermfn, "", "", Nothing)

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmann , ("Typeable", typeablefn, "", "", Nothing)

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmann , ("UpPos", updateposfn, "", "", Nothing)]

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmann

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmann-- useful helper things

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel HausmannaddPrime doc = doc <> char '\''

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmann

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel HausmannppCons b vs = let c = ppCons' b vs in

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmann if null vs then c else parens c

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmann

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel HausmannppCons' b vs = fsep $ text (constructor b) : vs

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmann

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmann-- begin of PosItem derivation

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmannupdateposfn dat =

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmann if any ((elem posLC) . types) (body dat) then

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmann instanceSkeleton "PosItem" [ (makeGetPosFn, empty) ] dat

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmann else empty

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmann

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel HausmannposLC = Con "Range"

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmann

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel HausmannmakeGetPosFn b =

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmann let (e, vs) = mapAccumL accFun empty (types b)

6a4fa2d53294f484fa8788a75656eff4ad1fd703Daniel Hausmann accFun d t = if isEmpty d && t == posLC

then (text "p", text "p")

else (d, text "_")

in hang (text "getRange" <+> ppCons b vs <+> text "=")

4 $ if isEmpty e then text "nullRange" else e

-- end of PosItem derivation

-- begin of ShATermConvertible derivation

shatermfn dat

= instanceSkeleton "ShATermConvertible"

[ (makeToShATerm, empty) ]

dat

$$ makeFromShATermFn dat

att i = text $ "att" ++ show (i :: Int)

makeToShATerm b

= let ts = types b

vs = varNames ts

in text "toShATerm" <+> att 0 <+> -- this first argument is an ATermTable

ppCons b vs <+>

text "=" $$ nest 4

(vcat (zipWith childToShATerm vs [0 :: Int ..]) $$

text "addATerm (ShAAppl" <+>

doubleQuotes (text (constructor b)) <+>

bracketList (varNames' ts) <+> text "[])" <+>

att (length ts) <+>

closeBraces ts)

closeBraces = hcat . map (const $ char '}')

pair f s = parens $ f <> comma <+> s

childToShATerm v i = let

attN_v' = pair (att $ i + 1) $ addPrime v

in text "case" <+> text "toShATerm" <+> att i <+> v

<+> text "of {" <+> attN_v' <+> text "->"

makeFromShATermFn dat =

block [text "fromShATermAux ix att0 =",

block [fnstart, block $ cases ++ [def_case]]]

where

fnstart = text "case getShATerm ix att0 of"

cases = map makeFromShATerm (body dat)

typename = name dat

u = text "u"

def_case = u <+> text "-> fromShATermError" <+>

doubleQuotes (text typename) <+> u

makeFromShATerm b

= let ts = types b

cvs = varNames ts

childFromShATerm v i =

text "case fromShATerm'"

<+> v <+> att i <+> text "of {"

<+> pair (att $ i + 1) (addPrime v) <+> text "->"

in text "ShAAppl" <+> doubleQuotes (text $ constructor b) <+>

bracketList cvs <+> text "_ ->"

$$ nest 4 (

block (zipWith childFromShATerm cvs [0 :: Int ..] ++

[pair (att $ length ts) (ppCons' b $ varNames' ts)

<+> closeBraces ts]))

-- end of ATermConvertible derivation

typeablefn :: Data -> Doc

typeablefn dat

= tcname <+> dc <+> text "TyCon" $$

tcname <+> equals <+> text "mkTyCon" <+>

doubleQuotes (text $ name dat) $$

instanceSkeleton "Typeable" [] dat $$ block (

[ text "typeOf" <+> text (if null tvars then "_" else "x")

<+> equals <+> text "mkTyConApp" <+>

tcname <+>

brackets (hcat $ sepWith comma $ map getV' tvars) $$

wheres ])

where

tvars = vars dat

dc = text "::"

tcname = text $ "_tc_" ++ name dat ++ "Tc"

wheres = where_decls $ map getV tvars

tpe = text (name dat) <+> hcat (sepWith space $ map text tvars)

getV' var

= text "typeOf" <+> parens (text "get" <> text var <+> text "x")

getV var

= text "get" <> text var <+> dc <+> tpe <+> rArrow

<+> text var $$

text "get" <> text var <+> equals <+> text "undefined"

where_decls [] = empty

where_decls ds = text " where" $$ block ds