StandardRules.lhs revision 8b3a5b62c1553ea72b6b3f9d24f6d6306b5dd273
e8058322725ba050014777ee2484f7e833ab1e3aLukas Slebodnik>module StandardRules (Tag,Rule,standardRules) where
11496692da75a330de01d5f15b7183d2439efd3cLukas Slebodnik>import RuleUtils
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek>type Tag = String
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek>type Rule = (Tag,Data -> Doc)
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek--- Add Rules Below Here ----------------------------------------------------
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek>standardRules :: [Rule]
37ea8e70fa13ff9ba563300fb15de0e5e6185d68Lukas Slebodnik>standardRules = [("test",dattest),
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek> ("update",updatefn),("is",isfn),("has",hasfn),
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek> ("un",unfn),
8d00718b943ab8b326320feb50820f0663031817Stephen Gallagher> ("NFData",nffn),
8d00718b943ab8b326320feb50820f0663031817Stephen Gallagher> ("Eq",eqfn),("Ord",ordfn),("Enum",enumfn),
8d00718b943ab8b326320feb50820f0663031817Stephen Gallagher> ("Show",showfn),("Read",readfn),
8d00718b943ab8b326320feb50820f0663031817Stephen Gallagher> ("Bounded",boundedfn)]
8d00718b943ab8b326320feb50820f0663031817Stephen Gallagher-----------------------------------------------------------------------------
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub HrozekNFData - This class provides 'rnf' to reduce to normal form.
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub HrozekThis has a default for non-constructed datatypes
8d00718b943ab8b326320feb50820f0663031817Stephen GallagherAssume that base cases have been defined for lists, functions, and
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek(arbitrary) tuples - makeRnf produces a function which applies rnf to
c9f6ca2ca7399c301853ff774c20883fef2b2267Stephen Gallaghereach of the combined types in each constructor of the datatype. (If
c9f6ca2ca7399c301853ff774c20883fef2b2267Stephen Gallagherthis isn't very clear, just look at the code to figure out what happens)
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek>nffn = instanceSkeleton "NFData" [(makeRnf,empty)]
37ea8e70fa13ff9ba563300fb15de0e5e6185d68Lukas Slebodnik>makeRnf :: IFunction
37ea8e70fa13ff9ba563300fb15de0e5e6185d68Lukas Slebodnik>makeRnf (Body{constructor=constructor,types=types})
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek> | null types = text "rnf" <+>
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek> fsep [pattern constructor [],equals,text "()"]
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek> | otherwise = let
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek> vars = varNames types
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek> head = [pattern constructor vars, equals]
37ea8e70fa13ff9ba563300fb15de0e5e6185d68Lukas Slebodnik> body = sepWith (text "`seq`") . map (text "rnf" <+>) $ vars
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek> in text "rnf" <+> fsep (head ++ body)
11496692da75a330de01d5f15b7183d2439efd3cLukas Slebodnik-----------------------------------------------------------------------------
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub HrozekForming 'update' functions for each label in a record
c9f6ca2ca7399c301853ff774c20883fef2b2267Stephen Gallagherfor a datatype G, where label has type G -> a
11496692da75a330de01d5f15b7183d2439efd3cLukas Slebodnikthe corresponding update fn has type (a -> a) -> G -> G
c9f6ca2ca7399c301853ff774c20883fef2b2267Stephen GallagherThe update fn has the same name as the label with _u appended
0a0d272844108fe3650a206c39dd4047f10003f2Gowrishankar Rajaiyanan example of what we want to generate
675f529e1a0ada1b1a400a59465560ab88a6e24cStephen Gallagher --> foo_u f d{foo}=d{foo = f foo}
37ea8e70fa13ff9ba563300fb15de0e5e6185d68Lukas Slebodniklabels can be common to more than one constructor in a type. -- this
8d00718b943ab8b326320feb50820f0663031817Stephen Gallagheris a problem, and the reason why a sort is used.
37ea8e70fa13ff9ba563300fb15de0e5e6185d68Lukas Slebodnik>updatefn :: Data -> Doc
764bda08267d867a30ceb07d398dc30be1f4b699Stephen Gallagher>updatefn d@(D{body=body,name=name})
764bda08267d867a30ceb07d398dc30be1f4b699Stephen Gallagher> | hasRecord d = vcat (updates ++ sets)
764bda08267d867a30ceb07d398dc30be1f4b699Stephen Gallagher> | otherwise = commentLine $
675f529e1a0ada1b1a400a59465560ab88a6e24cStephen Gallagher> text "Warning - can't derive `update' functions for non-record type: "
675f529e1a0ada1b1a400a59465560ab88a6e24cStephen Gallagher> <+> text name
764bda08267d867a30ceb07d398dc30be1f4b699Stephen Gallagher> labs = sort . concatMap f $ body
37ea8e70fa13ff9ba563300fb15de0e5e6185d68Lukas Slebodnik> updates = map genup labs
764bda08267d867a30ceb07d398dc30be1f4b699Stephen Gallagher> sets = map genset . nub . map fst $ labs
764bda08267d867a30ceb07d398dc30be1f4b699Stephen Gallagher> f :: Body -> [(Name,Constructor)]
675f529e1a0ada1b1a400a59465560ab88a6e24cStephen Gallagher> f (Body{constructor=constructor,labels=labels}) =
764bda08267d867a30ceb07d398dc30be1f4b699Stephen Gallagher> zip (filter (not . null) labels ) (repeat constructor)
11496692da75a330de01d5f15b7183d2439efd3cLukas Slebodnik>genup :: (Name,Constructor) -> Doc
11496692da75a330de01d5f15b7183d2439efd3cLukas Slebodnik>genup (n,c) = hsep [text (n ++ "_u")
764bda08267d867a30ceb07d398dc30be1f4b699Stephen Gallagher> , char 'r' <> char '@' <> text c <> braces (text n)
8d00718b943ab8b326320feb50820f0663031817Stephen Gallagher> , char 'r' <> braces (hsep [text n, text "= f", text n])]
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek>-- while we're at it, may as well define a set function too...
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek>genset :: Name -> Doc
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek>genset n = hsep [text (n ++ "_s v = "), text (n ++ "_u"), text " (const v)"]
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek----------------------------------------------------------------------
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub HrozekSimilar rules to provide predicates for the presence of a constructor / label
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek>isfn :: Data -> Doc
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek>isfn (D{body=body}) = vcat (map is body)
5daa8ae758349c0077fb5f664579809aa0ab4f78Stephen Gallagher> is Body{constructor=constructor,types=types} = let
5daa8ae758349c0077fb5f664579809aa0ab4f78Stephen Gallagher> fnName = text ("is" ++ constructor)
5daa8ae758349c0077fb5f664579809aa0ab4f78Stephen Gallagher> fn = fnName <+>
11496692da75a330de01d5f15b7183d2439efd3cLukas Slebodnik> hsep [pattern constructor types,text "=",text "True"]
5daa8ae758349c0077fb5f664579809aa0ab4f78Stephen Gallagher> defaultFn = fnName <+> hsep (texts ["_","=","False"])
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek> in fn $$ defaultFn
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek>hasfn :: Data -> Doc
11496692da75a330de01d5f15b7183d2439efd3cLukas Slebodnik>hasfn d@(D{body=body,name=name})
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek> | hasRecord d = vcat [has l b | l <- labs, b <- body]
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek> | otherwise = commentLine $
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek> text "Warning - can't derive `has' functions for non-record type:"
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek> <+> text name
11496692da75a330de01d5f15b7183d2439efd3cLukas Slebodnik> has lab Body{constructor=constructor,labels=labels} = let
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek> bool = text . show $ lab `elem` labels
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek> pattern = text (constructor ++ "{}")
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek> fnName = text ( "has" ++ lab)
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek> in fsep[fnName, pattern, text "=", bool]
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek> labs = nub . concatMap (labels) $ body
11496692da75a330de01d5f15b7183d2439efd3cLukas SlebodnikFunction to make using newtypes a bit nicer.
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozekfor newtype N = T a , unN :: T -> a
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek>unfn :: Data -> Doc
5daa8ae758349c0077fb5f664579809aa0ab4f78Stephen Gallagher>unfn (D{body=body,name=name,statement=statement}) | statement == DataStmt
5daa8ae758349c0077fb5f664579809aa0ab4f78Stephen Gallagher> = commentLine
5daa8ae758349c0077fb5f664579809aa0ab4f78Stephen Gallagher> $ text "Warning - can't derive 'un' function for data declaration "
5daa8ae758349c0077fb5f664579809aa0ab4f78Stephen Gallagher> <+> text name
11496692da75a330de01d5f15b7183d2439efd3cLukas Slebodnik> = let fnName = text ("un" ++ name)
5daa8ae758349c0077fb5f664579809aa0ab4f78Stephen Gallagher> b = head body
5daa8ae758349c0077fb5f664579809aa0ab4f78Stephen Gallagher> pattern = parens $ text (constructor b) <+> text "a"
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek> in fsep [fnName,pattern, equals, text "a"]
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek-----------------------------------------------------------------------------
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub HrozekA test rule for newtypes datastructures - just outputs