Hi,
thanks for the last help and hints. I have encountered an other problem,
and again I don't quite understand the reason why I get the results I
get. ghci seems to infer different types for the same expression.
Consider that I have disabled the monomorphism restriction
in module AGC.lhs (which is attached).
and I have a toplevel definition of:
> mylength = synAttr listLength
loding the module in ghci (6.4) gives (beside some correct warnings):
$ Ok, modules loaded: Main.
$ *Main> :type synAttr
$ synAttr :: (Data b) => ((?stack::[Dyn]) => b -> a) -> Attr a
$ *Main> :type listLength
$ listLength :: (?stack::[Dyn]) => List -> Float
$ *Main> :type (synAttr listLength)
$ (synAttr listLength) :: Attr Float
$ *Main> :type mylength
$ mylength :: (?stack::[Dyn]) => Dyn -> Dyn -> [Dyn] -> Maybe Float
$ *Main> let mylength = synAttr listLength
$ *Main> :type mylength
$ mylength :: Dyn -> Dyn -> [Dyn] -> Maybe Float
where
> type Attr a = Dyn -> Dyn -> [Dyn]-> Maybe a
the problem I have is that inferred types for the toplevel declaration
mylength differ from the verbatim equal definition in the Let
experssion.
for the toplevel it infers:
mylength :: (?stack::[Dyn]) => Dyn -> Dyn -> [Dyn] -> Maybe Float
for the let-Binding
mylength :: Dyn -> Dyn -> [Dyn] -> Maybe Float
and this is what I expected.
Has anyone an Idea, why this happens?
best regards,
Eike Scholz
PS: Beware of the comments in the attached file. This file is under
heavy development. I am dyslexic and don't correct the comments
while continuously rewriting code and comments. I hope that the comments
are useful anyway.
The (+>) (~>) (#>) operators are broken at the moment and don't work the
way intended.
>{-# OPTIONS_GHC -fglasgow-exts #-}
>{-# OPTIONS_GHC -fno-monomorphism-restriction #-}
> import Data.Typeable
> import qualified Data.Dynamic as D
> import Data.Generics
> import Data.Maybe
> import Debug.Trace
> strace s = trace (show s) s
------------------------------------------------------------------------------
-- Description:
-- Attribute Grammar Combinators
trying to model an attribute grammer by an combinator dsl
by going through the example from
http://www.haskell.org/tmrwiki/WhyAttributeGrammarsMatter
by Wouter Swierstra for The Monad.Reader Issue Four 01-07-05
lets start with rewriting the test defintions:
DATA Root
| Root list : List
DATA List
| Nil
| Cons hd : Float tl : List
> data Root = Root List
> deriving (Typeable,Data,Show)
> data List = Cons Float List -- head and tail are in prelude
> | Nil
> deriving (Typeable,Data,Show)
now lets look how an attribute and a semantic:
ATTR List [ | | length : Float]
SEM List
| Nil lhs.length = 0.0
| Cons lhs.length = 1.0 + @tail.length
the length value is somehow accessed by
nodeName.AttrName
we'll use (+>) for (.) since (.) is allready assigned
for the same reason well use mylength
Lets simply define a type specific listLength
> type SynSem c v = (?stack :: [Dyn]) => c -> v
> listLength :: (?stack :: [Dyn]) => List -> Float
> listLength Nil = 0 -- the "parent" gets explained later
> listLength (Cons _ tl) = (1 + (tl+>mylength) ) -- length is prelude
This is quite straight, but uses the not jet defined attribute mylength,
We can define it with:
> mylength = synAttr listLength
we can define the sum Attribute in the same way:
<> listSum :: SynSem List Float
<> listSum Nil = 0 -- the "parent" gets explained later
<> listSum (Cons v tl) = (v + (tl+>mysum) ) -- length is prelude
<> mysum = synAttr listSum
well syntesised symantics seem to be simple.
so lets look at the inherited sematics:
ATTR List [ avg : Float | | ]
SEM Root
| Root list.avg = @list.sum / @list.length
SEM List
| Cons tail.avg = @lhs.avg
lets assume we have allready defined the synthesised semantics for sum.
lets look at the cons example: it tells us,
that the average at the tail is the local average.
With the combinators it is translates to:
<> root_list_Avg :: InhSem Root List Float
<> root_list_Avg (Root _) l = ((l+>mysum) / (l+>mylength))
<> cons_tail_Avg :: InhSem List List Float
<> cons_tail_Avg parent@(Cons _ _) l = parent~>avg
<> avg = (inhAttr root_list_Avg) -- at this point we want to drop the
<> ?+ (inhAttr cons_tail_Avg) -- monomorphism restriction
now a test type
> tl = (Cons 2 (Cons 8 (Cons 20 (Cons 10 Nil))))
when we want to acces a Attribute outside the semantic functions
we have initialise the parent stack
<> l = tl?>mylength
<> s = tl?>mysum
<> av = (Root tl)?>avg
--------------------------------------------------------------------------
-- Implementation
> type InhSem p c v = (?stack :: [Dyn]) => p -> c -> v
> data None = None -- these are special placeohlders
> deriving (Typeable,Data,Show,Read,Eq)
> data Any = Any
> deriving (Typeable,Data,Show,Read,Eq)
the Attr agruments, are the parent, this node, and a stack (list) containing
all parents.
> type Attr a = Dyn -> Dyn -> [Dyn]-> Maybe a
> attr :: forall p b a . (Typeable p,Typeable b) => ((?stack::[Dyn])=>p->b->a) -> Attr a
> attr f p' b' st
> = let ?stack = strace ((packDyn b'):st)
> in if ( typeOf (fstType f) == (typeOf Any))
> then
> if typeOf (sndType f) == (typeOf Any)
> then Just (f dynAny dynAny') -- matches anything
> else if storedType b' == (typeOf (sndType f)) -- we are plain syn
> then Just (f dynAny (fromDyn b'))
> else Nothing
> else if storedType p' == (typeOf (fstType f)) -- we are inh.
> then if typeOf (sndType f) == (typeOf Any)
> then Just (f (fromDyn p') dynAny') -- we are plain inh.
> else if storedType b' == (typeOf (sndType f))
> then Just (f (fromDyn p') (fromDyn b'))-- syn&inh
> else Nothing
> else Nothing
> where
> dynAny = fromDyn (toDyn Any)
> dynAny' = fromDyn (toDyn Any) -- fighting monomorphism restriction
any should match Any type but the "None" type, since this is a
placeholder for an undefined type
recreating th synAttr
> synAttr :: (Data b) => ((?stack::[Dyn])=>b->a) -> Attr a
> synAttr f = attr (conv f)
> where
> conv :: ((?stack::[Dyn]) => b -> a) -> ((?stack::[Dyn]) => Any -> b -> a)
> conv f = \Any c -> f c
<> inhAttr = attr
> parent :: (?stack::[Dyn]) => Dyn
> parent = if length ?stack > 1
> then (?stack)!!1
> else (toDyn None)
> this :: (?stack::[Dyn]) => Dyn
> this = if length ?stack > 0
> then (?stack)!!0
> else (toDyn None)
> packDyn d = if typeOf d == typeOf (udef::Dyn)
> then D.fromDyn (D.toDyn d) udef
> else toDyn d
>
> (+>) :: (?stack :: [Dyn] , Data t) => t -> Attr a -> a
> (+>) t f
> = let st = ?stack -- this is quite irritating
> in case (f parent this st) of -- its not an infinite list, its an update
> (Just a) -> a
> Nothing -> error ("local lookup (+>) failed:\n"++noSemFoundErr)
-- acces a parents value
> (~>) :: (?stack :: [Dyn] , Data t) => t -> Attr a -> a
> (~>) t f = let st = tail ?stack
> in case f p (toDyn t) st of
> (Just a) -> a
> Nothing -> error ("parent lookup (~>) failed:\n"
> ++noSemFoundErr )
> where
> p = head ?stack
> ns = tail ?stack
-- acces from outside
> (?>) :: Data t => t -> Attr a -> a
> (?>) = let ?stack = [] in (+>)
we need a way to join semantics
this operator will try the first sem, then the second
> (?+) :: Attr a -> Attr a -> Attr a
> (?+) s1 s2 p t st
> = case s1 p t st of
> Nothing -> case s2 p t st of
> Nothing -> error ("no semantics found for type \""
> ++(show (storedType t))
> ++"\" with parent of type \""
> ++(show (storedType p))++"\"" )
> ma -> ma
> ma -> ma
> noSemFoundErr :: (?stack::[Dyn]) => a
> noSemFoundErr
> = error ("no semantics found for type \""
> ++(show (storedType this))
> ++"\" with parent of type \""
> ++(show (storedType parent))++"\"" )
------------------------------------------------------------------------------
-- auxillary functions and definitions:
> udef = undefined
> fstType :: (a->b) -> a
> fstType f = udef
> sndType :: (a->b->c) -> b
> sndType f = udef
> data Dyn = Dyn TypeRep (D.Dynamic) [Dyn]
> deriving (Typeable)
> toDyn :: Data a => a -> Dyn
> toDyn x = Dyn (typeOf x) (D.toDyn x) (mkDyns (gmapQ mk x))
> where
> mk :: Data a' => a' -> (TypeRep,D.Dynamic,[Dyn])
> mk x' = (typeOf x',D.toDyn x',mkDyns (gmapQ mk x') )
> mkDyn (t,v,r) = Dyn t v r
> mkDyns xs = map mkDyn xs
> ns = (gmapQ mk x)
> instance Show Dyn where
> show (Dyn _ d _ ) = show d
> tryFromDyn (Dyn _ d _) = D.fromDynamic d
> fromDyn (Dyn _ d _) = (D.fromDyn d) (error "invalid cast from Dyn")
> storedType (Dyn t _ _) = t
> dynContents (Dyn _ _ c) = c
> instance Data Dyn where
this is a hack, we actually don't need the implementation.
however packDyn needs this instance
------------------------------------------------------------------------------
-- test garbedge
<> (???) :: ( (?foo::Int) => b -> a) -> b -> a
<> (???) f x
<> = let ?foo = 1337
<> in f x
<> fun :: (?foo::Int,Show x) => x -> String
<> fun x = "x = "++(show x)++"; ?foo = "++(show ?foo)
<> test = (fun???)
<> undef = error ?errstr
<> (<?>) x s = let ?errstr = ?errstr++"\n"++s in x
_______________________________________________
Haskell mailing list
[email protected]
http://www.haskell.org/mailman/listinfo/haskell
