module DerivingDrift.StandardRules (standardRules,driftResolvedNames) where import DerivingDrift.RuleUtils import Name.Prim import Name.Name import qualified Data.Map as Map standardRules :: Map.Map Name.Name.Name (Data -> Doc) standardRules = Map.fromList [ (class_Eq,eqfn), (class_Ord,ordfn), (class_Enum,enumfn), (class_Show,showfn), (class_Read,readfn), (class_Bounded,boundedfn)] -- this list is to be feeded to the renamer in the -- renaming phase of the derived instances driftResolvedNames :: [(Name.Name.Name,[Name.Name.Name])] driftResolvedNames = map unkn stdCls ++ map self stdCls ++ map self stdVals where unkn n = (toName UnknownType (q n), [n]) self n = (n,[n]) stdCls = Map.keys standardRules stdVals = [v_sub,v_compose, dc_True,dc_False,v_and, dc_EQ,v_equals,v_geq,v_gt,v_compare, dc_Pair, dc_EmptyList,dc_Cons,v_foldl,v_cat,v_drop, v_showsPrec,v_showParen,v_showChar,v_showString, v_readsPrec,v_readParen,v_lex, v_fromEnum,v_toEnum,v_enumFrom,v_enumFromThen, v_minBound,v_maxBound] -- short for qualified and unqualified q,u :: Name.Name.Name -> String q = snd . fromName u = getIdent ------------------------------------------------------------------------------ -- Rules for the derivable Prelude Classes -- Eq eqfn = instanceSkeleton (q class_Eq) [(makeEq,defaultEq)] makeEq :: IFunction makeEq (Body{constructor=constructor,types=types}) | null types = hsep $ texts [constructor,u v_equals,constructor, "=", q dc_True] | otherwise = let v = varNames types v' = varNames' types d x = parens . hsep $ text constructor : x head = [ text (u v_equals), d v', text "="] body = sepWith (text $ q v_and) $ zipWith (\x y -> (x <+> text (q v_equals) <+> y)) v v' in d v <+> fsep (head ++ body) defaultEq = hsep $ texts ["_", u v_equals, "_", "=" ,q dc_False] ---------------------------------------------------------------------- -- Ord ordfn d = let ifn = [f c c' | c <- zip (body d) [1 :: Int ..] , c' <- zip (body d) [1 :: Int ..]] cmp n n' = show $ compare n n' f (b,n) (b',n') | null (types b) = text (u v_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 (q v_compare),x,y] list [x] [y] = one x y list xs ys = fsep [text (q v_foldl), parens fn, text (q dc_EQ), bracketList (zipWith one xs ys)] fn = fsep $ texts ["\\x y", "->", "if", "x", q v_equals, q dc_EQ, "then", q v_compare, "y", q dc_EQ, "else", "x"] in if constructor b == constructor b' then text (u v_compare) <+> fsep [head, list (varNames $ types b) (varNames' $ types b')] else text (u v_compare) <+> fsep [head,text (cmp n n')] in simpleInstance (q class_Ord) d <+> text "where" $$ block ifn ---------------------------------------------------------------------- -- Show & Read -- won't work for infix constructors -- -- Show showfn = instanceSkeleton (q class_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 (u v_showsPrec) headfn = fsep [char 'd',(pattern constructor types),equals] bodyStart = fsep [text (q v_showParen),parens $ fsep [text "d",text (q v_geq),text "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 (q v_showsPrec), text "10", x]) (varNames types) b' = zipWith (\x l -> fsep [showString l, comp, showString " = ", comp, x]) b (map getIdent labels) s = fsep [comp,showChar ' ', comp] s' = fsep [comp,showChar ',',comp] showChar c = fsep [text (q v_showChar), text ('\'':c:"\'")] showString s = fsep [text (q v_showString), doubleQuotes $ text s] comp = text (q v_compose) -- Read readfn d = simpleInstance (q class_Read) d <+> text "where" $$ readsPrecFn d readsPrecFn d = let fnName = text (u v_readsPrec) bodies = vcat $ sepWith (text $ q v_cat) (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 (q v_readParen), parens (text $ unwords ["d",q v_gt,"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 (tshow $ show (toUnqualified 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 (q v_lex),ip] readsPrec = fsep [text (q v_readsPrec),text "10"] from = text "<-" tshow x = text (show x) ---------------------------------------------------------------------- -- 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 (getIdent $ name d) else simpleInstance (q class_Enum) d <+> text "where" $$ block (fromE ++ toE ++ [eFrom,enumFromThenFn]) fromEnumFn :: Data -> [Doc] fromEnumFn (D{body=body}) = map f (zip body [0:: Int ..]) where f (Body{constructor=constructor},x) = text (u v_fromEnum) <+> (fsep $ texts [constructor , "=", show x]) toEnumFn :: Data -> [Doc] toEnumFn (D{body=body}) = map f (zip body [0 :: Int ..]) where f (Body{constructor=constructor},x) = text (u v_toEnum) <+> (fsep $ texts [show x , "=", constructor]) enumFromFn :: Data -> Doc enumFromFn D{body=body} = let conList = bracketList . texts . map constructor $ body bodydoc = fsep [char 'e', char '=', text (q v_drop), parens (text (q v_fromEnum) <+> char 'e'), conList] in text (u v_enumFrom) <+> bodydoc enumFromThenFn :: Doc enumFromThenFn = let wrapper = fsep $ texts ["i","j","=","enumFromThen\'","i","j","(", q v_enumFrom, "i", ")"] eq1 = text "enumFromThen\'" <+> fsep (texts ["_","_",u dc_EmptyList,"=",u dc_EmptyList]) eq2 = text "enumFromThen\'" <+> fsep (texts ["i","j","(x",u dc_Cons,"xs)","="]) <+> fsep [hsep $ texts [ "let", "d", "=", q v_fromEnum,"j",q v_sub,q v_fromEnum,"i"], text "in" <+> fsep (texts [ "x",u dc_Cons,"enumFromThen\'","i","j","(", q v_drop] ++ [parens . hsep $ texts ["d",q v_sub,"1"]] ++ [text "xs",text ")"])] in text (q v_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 $ getIdent name) boundedEnum d@D{body=body} = let f = constructor . head $ body l = constructor . last $ body in simpleInstance (q class_Bounded) d <+> text "where" $$ block [ hsep (texts [u v_minBound,"=",f]), hsep (texts [u v_maxBound,"=",l])] boundedSingle d@D{body=body} = let f = head $ body in simpleInstance (q class_Bounded) d <+> text "where" $$ block [ hsep . texts $ [u v_minBound,"=",constructor f] ++ replicate (length (types f)) (q v_minBound), hsep . texts $ [u v_maxBound,"=",constructor f] ++ replicate (length (types f)) (q v_maxBound)] singleton [x] = True singleton _ = False