diff options
-rw-r--r-- | AttributeData.hs | 27 |
1 files changed, 15 insertions, 12 deletions
diff --git a/AttributeData.hs b/AttributeData.hs index 2b2bc96..86cb1e4 100644 --- a/AttributeData.hs +++ b/AttributeData.hs | |||
@@ -36,6 +36,7 @@ import LambdaCube.GL.Util | |||
36 | import LambdaCube.GL.Input.Type | 36 | import LambdaCube.GL.Input.Type |
37 | import LambdaCube.GL.Input hiding (createObjectCommands) | 37 | import LambdaCube.GL.Input hiding (createObjectCommands) |
38 | 38 | ||
39 | import Control.Monad.State.Lazy | ||
39 | 40 | ||
40 | import MaskableStream | 41 | import MaskableStream |
41 | 42 | ||
@@ -75,17 +76,19 @@ foo lookupA = do | |||
75 | case dataTypeRep dt of | 76 | case dataTypeRep dt of |
76 | AlgRep (c:_) -> do | 77 | AlgRep (c:_) -> do |
77 | let fields = constrFields c | 78 | let fields = constrFields c |
78 | mkb :: Data k => String -> k | 79 | mkb :: (MonadPlus m, Data k) => String -> m k |
79 | mkb n = fix $ \v -> | 80 | mkb n = case lookupA n of |
80 | fromMaybe (error $ "mkb " ++ n) $ case lookupA n of | 81 | Just (This k@(AttributeKey tt _ _)) -> case tagTypable tt of |
81 | Just (This k@(AttributeKey tt _ _)) -> case tagTypable tt of | 82 | Witness -> maybe mzero return $ cast k |
82 | Witness -> cast k | 83 | _ -> mzero |
83 | _ -> Nothing | 84 | z :: x -> StateT [String] Maybe x |
84 | z :: x -> (,) [String] x | 85 | z r = put fields >> return r |
85 | z r = (fields, r) | 86 | k :: Data b => StateT [String] Maybe (b -> r) -> StateT [String] Maybe r |
86 | k :: Data b => (,) [String] (b -> r) -> (,) [String] r | 87 | k c = do btor <- c |
87 | k (n:ns,btor) = (ns,btor (mkb n)) | 88 | n:ns <- get |
88 | (_,ks) = gunfold k z c :: (,) [String] attrkeys | 89 | put ns |
89 | Just ks | 90 | a <- mkb n |
91 | return (btor a) | ||
92 | evalStateT (gunfold k z c) [] -- :: (,) [String] attrkeys | ||
90 | _ -> Nothing | 93 | _ -> Nothing |
91 | 94 | ||