StandardRules.lhs revision 8b3a5b62c1553ea72b6b3f9d24f6d6306b5dd273
e8058322725ba050014777ee2484f7e833ab1e3aLukas Slebodnik>module StandardRules (Tag,Rule,standardRules) where
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek
11496692da75a330de01d5f15b7183d2439efd3cLukas Slebodnik>import RuleUtils
11496692da75a330de01d5f15b7183d2439efd3cLukas Slebodnik>import List
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek>type Tag = String
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek>type Rule = (Tag,Data -> Doc)
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek--- Add Rules Below Here ----------------------------------------------------
8d00718b943ab8b326320feb50820f0663031817Stephen Gallagher
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
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
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek>nffn = instanceSkeleton "NFData" [(makeRnf,empty)]
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek
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)
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek>
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek
11496692da75a330de01d5f15b7183d2439efd3cLukas Slebodnik-----------------------------------------------------------------------------
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub HrozekForming 'update' functions for each label in a record
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek
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
c9f6ca2ca7399c301853ff774c20883fef2b2267Stephen Gallagher
0a0d272844108fe3650a206c39dd4047f10003f2Gowrishankar Rajaiyanan example of what we want to generate
675f529e1a0ada1b1a400a59465560ab88a6e24cStephen Gallagher --> foo_u f d{foo}=d{foo = f foo}
37ea8e70fa13ff9ba563300fb15de0e5e6185d68Lukas Slebodnik
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.
764bda08267d867a30ceb07d398dc30be1f4b699Stephen Gallagher
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
675f529e1a0ada1b1a400a59465560ab88a6e24cStephen Gallagher> where
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)
675f529e1a0ada1b1a400a59465560ab88a6e24cStephen Gallagher
11496692da75a330de01d5f15b7183d2439efd3cLukas Slebodnik>genup :: (Name,Constructor) -> Doc
11496692da75a330de01d5f15b7183d2439efd3cLukas Slebodnik>genup (n,c) = hsep [text (n ++ "_u")
675f529e1a0ada1b1a400a59465560ab88a6e24cStephen Gallagher> , char 'f'
764bda08267d867a30ceb07d398dc30be1f4b699Stephen Gallagher> , char 'r' <> char '@' <> text c <> braces (text n)
764bda08267d867a30ceb07d398dc30be1f4b699Stephen Gallagher> , equals
8d00718b943ab8b326320feb50820f0663031817Stephen Gallagher> , char 'r' <> braces (hsep [text n, text "= f", text n])]
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek
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 Hrozek----------------------------------------------------------------------
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub HrozekSimilar rules to provide predicates for the presence of a constructor / label
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek>isfn :: Data -> Doc
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek>isfn (D{body=body}) = vcat (map is body)
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek> where
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
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
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek> where
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
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek
11496692da75a330de01d5f15b7183d2439efd3cLukas Slebodnik
11496692da75a330de01d5f15b7183d2439efd3cLukas SlebodnikFunction to make using newtypes a bit nicer.
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozekfor newtype N = T a , unN :: T -> a
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek
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> | otherwise
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 Hrozek
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub Hrozek-----------------------------------------------------------------------------
530ba03ecabb472f17d5d1ab546aec9390492de1Jakub HrozekA test rule for newtypes datastructures - just outputs
parsed information. Can put {-! global : Test !-} in an input file, and output
from the entire file should be generated.
>dattest d = commentBlock . vcat $
> [text (name d)
> , fsep . texts . map show $ constraints d
> , fsep . texts . map show $ vars d
> , fsep . texts . map show $ body d
> , fsep . texts . map show $ derives d
> , text . show $statement d]
------------------------------------------------------------------------------
Rules for the derivable Prelude Classes
Eq
>eqfn = instanceSkeleton "Eq" [(makeEq,defaultEq)]
>makeEq :: IFunction
>makeEq (Body{constructor=constructor,types=types})
> | null types = hsep $ texts [constructor,"==",constructor, "=", "True"]
> | otherwise = let
> v = varNames types
> v' = varNames' types
> d x = parens . hsep $ text constructor : x
> head = [ text "==", d v', text "="]
> body = sepWith (text "&&") $
> zipWith (\x y -> (x <+> text "==" <+> y)) v v'
> in d v <+> fsep (head ++ body)
>defaultEq = hsep $ texts ["_", "==", "_", "=" ,"False"]
----------------------------------------------------------------------
Ord
>ordfn d = let
> ifn = [f c c'
> | c <- zip (body d) [1 ..]
> , c' <- zip (body d) [1 ..]]
> cmp n n' = show $ compare n n'
> f (b,n) (b',n')
> | null (types b) = text "compare" <+>
> fsep [text (constructor b),
> pattern (constructor b') (types b')
> , char '=', text $ cmp n n' ]
> | otherwise = let
> head = fsep [l,r, char '=']
> l = pattern (constructor b) (types b)
> r = pattern' (constructor b') (types b')
> one x y = fsep [text "compare",x,y]
> list [x] [y] = one x y
> list xs ys = fsep [text "foldl", parens fn, text "EQ",
> bracketList (zipWith one xs ys)]
> fn = fsep $ texts ["\\x y", "->", "if", "x", "==","EQ",
> "then", "compare", "y", "EQ", "else", "y"]
> in if constructor b == constructor b' then
> text "compare" <+> fsep [head,
> list (varNames $ types b) (varNames' $ types b')]
> else text "compare" <+> fsep [head,text (cmp n n')]
> in simpleInstance "Ord" d <+> text "where" $$ block ifn
----------------------------------------------------------------------
Show & Read
won't work for infix constructors
(and anyway, neither does the parser currently)
Show
>showfn = instanceSkeleton "Show" [(makeShow,empty)]
>makeShow :: IFunction
>makeShow (Body{constructor=constructor,labels=labels,types=types})
> | null types = fnName <+> fsep [headfn,showString constructor]
> | null labels = fnName <+> fsep [headfn,bodyStart, body] -- datatype
> | otherwise = fnName <+> fsep[headfn,bodyStart,recordBody] -- record
> where
> fnName = text "showsPrec"
> headfn = fsep [char 'd',(pattern constructor types),equals]
> bodyStart = fsep [text "showParen",parens (text "d >= 10")]
> body = parens . fsep $ sepWith s (c : b)
> recordBody = parens $ fsep [c,comp,showChar '{',comp,
> fsep (sepWith s' b'),comp,showChar '}']
> c = showString constructor
> b = map (\x -> fsep[text "showsPrec", text "10", x]) (varNames types)
> b' = zipWith (\x l -> fsep[showString l,comp,showChar '=',comp,x])
> b labels
> s = fsep [comp,showChar ' ', comp]
> s' = fsep [comp,showChar ',',comp]
> showChar c = fsep [text "showChar", text ('\'':c:"\'")]
> showString s = fsep[ text "showString", doubleQuotes $ text s]
> comp = char '.'
Read
>readfn d = simpleInstance "Read" d <+> text "where" $$ readsPrecFn d
>readsPrecFn d = let
> fnName = text "readsPrec"
> bodies = vcat $ sepWith (text "++") (map makeRead (body d))
> in nest 4 $ fnName <+> fsep[char 'd', text "input", equals,bodies]
>makeRead :: IFunction
>makeRead (Body{constructor=constructor,labels=labels,types=types})
> | null types = fsep [read0,text "input"]
> | null labels = fsep [headfn,read,text "input"]
> | otherwise = fsep [headfn,readRecord, text "input"]
> where
> headfn = fsep [text "readParen", parens (text "d > 9")]
> read0 = lambda $ listComp (result rest) [lexConstr rest]
> read = lambda . listComp (result rest)
> $ lexConstr ip : ( map f (init vars) )
> ++ final (last vars)
> f v = fsep [tup v ip, from,readsPrec, ip]
> final v = [fsep[tup v rest,from,readsPrec,ip]]
> readRecord = let
> f lab v = [
> fsep [tup (text $ show lab) ip,lex],
> fsep [tup (text $ show "=") ip,lex],
> fsep [tup v ip ,from,readsPrec,ip]]
> openB = fsep [tup (text $ show "{") ip,lex]
> closeB = fsep [tup (text $ show "}") rest,lex]
> comma = [fsep [tup (text $ show ",") ip,lex]]
> in lambda . listComp (result rest)
> $ lexConstr ip : openB
> : (concat . sepWith comma) (zipWith f labels vars)
> ++ [closeB]
> lambda x = parens ( fsep [text "\\",ip,text "->",x])
> listComp x (l:ll) = brackets . fsep . sepWith comma $
> ((fsep[x, char '|', l]) : ll)
> result x = tup (pattern constructor vars) x
> lexConstr x = fsep [tup (text $ show constructor) x, lex]
> -- nifty little bits of syntax
> vars = varNames types
> ip = text "inp"
> rest = text "rest"
> tup x y = parens $ fsep [x, char ',',y]
> lex = fsep[from,text "lex",ip]
> readsPrec = fsep [text "readsPrec",text "10"]
> from = text "<-"
----------------------------------------------------------------------
Enum -- a lot of this code should be provided as default instances,
but currently isn't
>enumfn d = let
> fromE = fromEnumFn d
> toE = toEnumFn d
> eFrom = enumFromFn d
> in if any (not . null . types) (body d)
> then commentLine $ text "Warning -- can't derive Enum for"
> <+> text (name d)
> else simpleInstance "Enum" d <+> text "where"
> $$ block (fromE ++ toE ++ [eFrom,enumFromThenFn])
>fromEnumFn :: Data -> [Doc]
>fromEnumFn (D{body=body}) = map f (zip body [0 ..])
> where
> f (Body{constructor=constructor},n) = text "fromEnum" <+> (fsep $
> texts [constructor , "=", show n])
>toEnumFn :: Data -> [Doc]
>toEnumFn (D{body=body}) = map f (zip body [0 ..])
> where
> f (Body{constructor=constructor},n) = text "toEnum" <+> (fsep $
> texts [show n , "=", constructor])
>enumFromFn :: Data -> Doc
>enumFromFn D{body=body} = let
> conList = bracketList . texts . map constructor $ body
> bodydoc = fsep [char 'e', char '=', text "drop",
> parens (text "fromEnum" <+> char 'e'), conList]
> in text "enumFrom" <+> bodydoc
>enumFromThenFn :: Doc
>enumFromThenFn = let
> wrapper = fsep $ texts ["i","j","=","enumFromThen\'","i","j","(",
> "enumFrom", "i", ")"]
> eq1 = text "enumFromThen\'" <+> fsep (texts ["_","_","[]","=","[]"])
> eq2 = text "enumFromThen\'" <+> fsep ( texts ["i","j","(x:xs)","=",
> "let","d","=","fromEnum","j","-","fromEnum","i","in",
> "x",":","enumFromThen\'","i","j","(","drop","(d-1)","xs",")"])
> in text "enumFromThen" <+> wrapper $$ block [text "where",eq1,eq2]
----------------------------------------------------------------------
Bounded - as if anyone uses this one :-) ..
>boundedfn d@D{name=name,body=body,derives=derives}
> | all (null . types) body = boundedEnum d
> | singleton body = boundedSingle d
> | otherwise = commentLine $ text "Warning -- can't derive Bounded for"
> <+> text name
>boundedEnum d@D{body=body} = let f = constructor . head $ body
> l = constructor . last $ body
> in simpleInstance "Bounded" d <+> text "where" $$ block [
> hsep (texts[ "minBound","=",f]),
> hsep (texts[ "maxBound","=",l])]
>boundedSingle d@D{body=body} = let f = head $ body
> in simpleInstance "Bounded" d <+> text "where" $$ block [
> hsep . texts $ [ "minBound","=",constructor f] ++
> replicate (length (types f)) "minBound",
> hsep . texts $ [ "maxBound","=",constructor f] ++
> replicate (length (types f)) "maxBound"]
>singleton [x] = True
>singleton _ = False