module TraceDerive where import Syntax import TraceId (TraceId,mkLambdaBound,tokenId,getUnqualified,dropModule,modArity ,tPriority,tFixity,Fixity(..) ,tTokenTrue,tTokenFalse,tTokenEqualEqual,tTokenAndAnd ,tTokenEQ,tTokenCompare,tTokenLocalFromEnum,tTokenInt ,tTokenMinBound,tTokenMaxBound,tTokenFromEnum,tTokenToEnum ,tTokenError,tTokenEnumFrom,tTokenEnumFromThen,tTokenEnumFromTo ,tTokenEnumFromThenTo,tTokenGreater,tTokenGreaterEqual,tTokenCompose ,tTokenShowsPrec,tTokenShowParen,tTokenShowString,tTokenShowChar ,tTokenReadsPrec,tTokenReadParen,tTokenYield,tTokenAlt,tTokenThenAp ,tTokenThenLex,tTokenRange,tTokenIndex,tTokenInRange,tTokenMap,tTokenMinus ,tTokenLocalToEnum,tTokenTuple2,tTokenFun,tTokenRangeSize ,tTokenGtGtEq,tTokenPlus,tTokenTimes,tTokenReturn) import TokenId (mkUnqualifiedTokenId,tEq) import AuxTypes (defaultAuxInfo) -- ---------------------------------------------------------------------------- -- derive instances for all given classes for a data/newtype derive :: [Context TraceId] -> Simple TraceId -> [Constr TraceId] -> [(Pos,TraceId)] -> [Decl TraceId] derive tyContexts sTy constrs = map (deriveClass tyContexts (simpleToType sTy) pTyVars constrs) where Simple _ _ pTyVars = sTy -- derive instance for a given class for a data/newtype deriveClass :: [Context TraceId] -> Instance TraceId -> [(Pos,TraceId)] -> [Constr TraceId] -> (Pos,TraceId) -> Decl TraceId deriveClass tyContexts instTy pTyVars constrs (pos,cls) | getUnqualified cls == "Eq" = deriveEq pos usualContexts cls instTy constrs | getUnqualified cls == "Ord" = deriveOrd pos usualContexts cls instTy constrs | getUnqualified cls == "Bounded" = deriveBounded pos usualContexts cls instTy constrs | getUnqualified cls == "Enum" = deriveEnum pos usualContexts cls instTy constrs | getUnqualified cls == "Read" = deriveRead pos usualContexts cls instTy constrs | getUnqualified cls == "Show" = deriveShow pos usualContexts cls instTy constrs | getUnqualified cls == "Ix" = deriveIx pos usualContexts cls instTy constrs | otherwise = error ("deriveClass: unknown class " ++ show (tokenId cls)) where -- this is a HACK that covers only the common cases -- for correct result would need to implement full context reduction -- and take the least fixpoint usualContexts = tyContexts ++ map (\pt-> Context pos cls [pt]) pTyVars -- ---------------------------------------------------------------------------- deriveEq :: Pos -> [Context TraceId] -> TraceId -> Instance TraceId -> [Constr TraceId] -> Decl TraceId deriveEq pos contexts cls ty constrs = DeclInstance pos contexts cls [ty] (DeclsParse [DeclFun pos (modArity (dropModule tTokenEqualEqual) 2) (map funEqConstr constrs ++ [Fun [PatWildcard pos,PatWildcard pos] (Unguarded (ExpCon pos tTokenFalse)) noDecls])]) where vars = traceVars pos funEqConstr :: Constr TraceId -> Fun TraceId funEqConstr constr = if arity == 0 then Fun [ExpCon pos conId,ExpCon pos conId] (Unguarded (ExpCon pos tTokenTrue)) noDecls else Fun [ExpApplication pos (ExpCon pos conId : argsL) , ExpApplication pos (ExpCon pos conId : argsR)] (Unguarded (foldr1 andExp (zipWith equalExp argsL argsR))) noDecls where andExp :: Exp TraceId -> Exp TraceId -> Exp TraceId andExp e1 e2 = ExpApplication pos [ExpVar pos tTokenAndAnd,e1,e2] equalExp :: Exp TraceId -> Exp TraceId -> Exp TraceId equalExp e1 e2 = ExpApplication pos [ExpVar pos tTokenEqualEqual,e1,e2] (argsL,restVars) = splitAt arity vars argsR = take arity restVars conId = getConstrId constr arity = constrArity constr -- ---------------------------------------------------------------------------- deriveOrd :: Pos -> [Context TraceId] -> TraceId -> Instance TraceId -> [Constr TraceId] -> Decl TraceId deriveOrd pos contexts cls ty constrs = DeclInstance pos contexts cls [ty] (DeclsParse [DeclFun pos (modArity (dropModule tTokenCompare) 2) (concatMap funCompareEqConstr constrs ++ [Fun [var1,var2] (Unguarded (ExpApplication pos [ExpVar pos tTokenCompare ,ExpType pos (ExpApplication pos [localFromEnumVar,var1]) [] (TypeCons pos tTokenInt []) ,ExpApplication pos [localFromEnumVar,var2]])) (DeclsParse [DeclFun pos tTokenLocalFromEnum (zipWith funLocalFromEnum constrs [0..])])])]) where var1:var2:vars = traceVars pos localFromEnumVar = ExpVar pos tTokenLocalFromEnum funCompareEqConstr constr = if arity == 0 then [] else [Fun [ExpApplication pos (ExpCon pos conId : argsL) ,ExpApplication pos (ExpCon pos conId : argsR)] (Unguarded (foldr1 caseExp (zipWith compareExp argsL argsR))) noDecls] where caseExp :: Exp TraceId -> Exp TraceId -> Exp TraceId caseExp e1 e2 = ExpCase pos e1 [Alt (ExpCon pos tTokenEQ) (Unguarded e2) noDecls ,Alt var1 (Unguarded var1) noDecls] compareExp :: Exp TraceId -> Exp TraceId -> Exp TraceId compareExp e1 e2 = ExpApplication pos [ExpVar pos tTokenCompare,e1,e2] (argsL,restVars) = splitAt arity vars argsR = take arity restVars conId = getConstrId constr arity = constrArity constr funLocalFromEnum constr num = Fun [ExpApplication pos (ExpCon pos conId : args)] (Unguarded (ExpLit pos (LitInteger Boxed num))) noDecls where args = replicate (constrArity constr) (PatWildcard pos) conId = getConstrId constr -- ---------------------------------------------------------------------------- deriveBounded :: Pos -> [Context TraceId] -> TraceId -> Instance TraceId -> [Constr TraceId] -> Decl TraceId deriveBounded pos contexts cls ty constrs = DeclInstance pos contexts cls [ty] (if all (== 0) (map constrArity constrs) then (DeclsParse [DeclFun pos (modArity (dropModule tTokenMinBound) 0) [Fun [] (Unguarded (ExpCon pos (getConstrId (head constrs)))) noDecls] ,DeclFun pos (modArity (dropModule tTokenMaxBound) 0) [Fun [] (Unguarded (ExpCon pos (getConstrId (last constrs)))) noDecls]]) else {- exactly one constructor -} let [constr] = constrs in (DeclsParse [DeclFun pos (modArity (dropModule tTokenMinBound) 0) [Fun [] (Unguarded (ExpApplication pos (ExpCon pos (getConstrId (head constrs)) : replicate (constrArity constr) (ExpVar pos tTokenMinBound)) )) noDecls] ,DeclFun pos (modArity (dropModule tTokenMaxBound) 0) [Fun [] (Unguarded (ExpApplication pos (ExpCon pos (getConstrId (head constrs)) : replicate (constrArity constr) (ExpVar pos tTokenMaxBound)) )) noDecls]])) -- ---------------------------------------------------------------------------- deriveEnum :: Pos -> [Context TraceId] -> TraceId -> Instance TraceId -> [Constr TraceId] -> Decl TraceId deriveEnum pos contexts cls ty constrs = -- assert: all (== 0) (map constrArity constrs) DeclInstance pos contexts cls [ty] (DeclsParse [DeclFun pos (modArity (dropModule tTokenFromEnum) 1) (zipWith funFromEnum constrs [0..]) ,DeclFun pos (modArity (dropModule tTokenToEnum) 1) (zipWith funToEnum constrs [0..] ++ [Fun [PatWildcard pos] (Unguarded (ExpApplication pos [ExpVar pos tTokenError ,ExpLit pos (LitString Boxed "toEnum: argument out of bounds")])) noDecls]) ,DeclFun pos (modArity (dropModule tTokenEnumFrom) 1) [Fun [var1] (Unguarded (ExpApplication pos [ExpVar pos tTokenEnumFromTo,var1 ,ExpCon pos (getConstrId (last constrs))])) noDecls] ,DeclFun pos (modArity (dropModule tTokenEnumFromThen) 2) [Fun [var1,var2] (Unguarded (ExpApplication pos [ExpVar pos tTokenEnumFromThenTo,var1,var2 ,ExpIf pos (ExpApplication pos [ExpVar pos tTokenGreaterEqual ,ExpApplication pos [ExpVar pos tTokenFromEnum,var1] ,ExpApplication pos [ExpVar pos tTokenFromEnum,var2]]) (ExpCon pos (getConstrId (last constrs))) (ExpCon pos (getConstrId (head constrs)))])) noDecls] ]) where var1:var2:_ = traceVars pos funFromEnum constr num = Fun [ExpCon pos (getConstrId constr)] (Unguarded (ExpLit pos (LitInteger Boxed num))) noDecls funToEnum constr num = Fun [ExpLit pos (LitInteger Boxed num)] (Unguarded (ExpCon pos (getConstrId constr))) noDecls -- ---------------------------------------------------------------------------- deriveShow :: Pos -> [Context TraceId] -> TraceId -> Instance TraceId -> [Constr TraceId] -> Decl TraceId deriveShow pos contexts cls ty constrs = DeclInstance pos contexts cls [ty] (DeclsParse [DeclFun pos (modArity (dropModule tTokenShowsPrec) 2) (map funShowsPrec constrs)]) where precVar:vars = traceVars pos funShowsPrec constr = Fun [precVar,ExpApplication pos (ExpCon pos conId:args)] (Unguarded (if arity == 0 then showStringExp (getUnqualified conId) else case getUnqualified conId of ':':_ -> -- is defined in infix style (and arity == 2) ExpApplication pos [ExpVar pos tTokenShowParen ,ExpApplication pos [ExpVar pos tTokenGreater,precVar ,ExpLit pos (LitInteger Boxed priority)] , showPrec priorityPlus1 (head args) `compose` showStringExp (' ' : getUnqualified conId ++ " ") `compose` showPrec priorityPlus1 (args!!1) ] _ -> let labels = map snd . getConstrLabels $ constr in if null labels then ExpApplication pos [ExpVar pos tTokenShowParen ,ExpApplication pos [ExpVar pos tTokenGreater,precVar ,ExpLit pos (LitInteger Boxed priority)] ,showStringExp (getUnqualified conId ++ " ") `compose` foldr1 composeSpace (map (showPrec priorityPlus1) args) ] else showStringExp (getUnqualified conId ++ "{") `compose` foldr1 composeComma (zipWith showField labels args) `compose` showCharExp '}' )) noDecls where showStringExp s = ExpApplication pos [ExpVar pos tTokenShowString ,ExpLit pos (LitString Boxed s)] showCharExp c = ExpApplication pos [ExpVar pos tTokenShowChar ,ExpLit pos (LitChar Boxed c)] e1 `compose` e2 = ExpApplication pos [ExpVar pos tTokenCompose,e1,e2] e1 `composeSpace` e2 = e1 `compose` showCharExp ' ' `compose` e2 e1 `composeComma` e2 = e1 `compose` showCharExp ',' `compose` e2 showField label e = showStringExp (getUnqualified label) `compose` showCharExp '=' `compose` showPrec 0 e showPrec d e = ExpApplication pos [ExpVar pos tTokenShowsPrec,ExpLit pos (LitInteger Boxed d),e] args = take arity vars conId = getConstrId constr arity = constrArity constr priority = toInteger (tPriority conId) priorityPlus1 = priority+1 -- ---------------------------------------------------------------------------- deriveRead :: Pos -> [Context TraceId] -> TraceId -> Instance TraceId -> [Constr TraceId] -> Decl TraceId deriveRead pos contexts cls ty constrs = DeclInstance pos contexts cls [ty] (DeclsParse [DeclFun pos (modArity (dropModule tTokenReadsPrec) 1) [Fun [precVar] (Unguarded (foldr1 alt . map expReadsPrec $ constrs)) noDecls]]) where precVar:_ = traceVars pos e1 `alt` e2 = ExpApplication pos [ExpVar pos tTokenAlt,e1,e2] expReadsPrec constr = if arity == 0 then readParen (ExpCon pos tTokenFalse) (yield (ExpCon pos conId) `thenLex` getUnqualified conId) else case getUnqualified conId of ':':_ -> -- is defined in infix style (and arity == 2) readParen precGreaterPriority (yield (ExpCon pos conId) `thenAp` readsArg `thenLex` getUnqualified conId `thenAp` readsArg) _ -> let labels = map snd . getConstrLabels $ constr in if null labels then readParen precGreaterPriority (foldl thenAp (yield (ExpCon pos conId) `thenLex` getUnqualified conId) (replicate arity readsArg)) else (foldl thenCommaField (yield (ExpCon pos conId) `thenLex` getUnqualified conId `thenLex` "{" `thenField` (head labels)) (tail labels)) `thenLex` "}" where infixl 6 `thenAp`,`thenLex`, `thenField` readParen c e = ExpApplication pos [ExpVar pos tTokenReadParen,c,e] yield e = ExpApplication pos [ExpVar pos tTokenYield,e] e1 `thenLex` s = ExpApplication pos [ExpVar pos tTokenThenLex,e1,string s] e1 `thenAp` e2 = ExpApplication pos [ExpVar pos tTokenThenAp,e1,e2] precGreaterPriority = ExpApplication pos [ExpVar pos tTokenGreater,precVar ,ExpLit pos (LitInteger Boxed priority)] string s = ExpLit pos (LitString Boxed s) readsArg = ExpApplication pos [ExpVar pos tTokenReadsPrec ,ExpLit pos (LitInteger Boxed priorityPlus1)] readsArg0 = ExpApplication pos [ExpVar pos tTokenReadsPrec ,ExpLit pos (LitInteger Boxed 0)] p `thenField` label = p `thenLex` getUnqualified label `thenLex` "=" `thenAp` readsArg0 p `thenCommaField` label = p `thenLex` "," `thenField` label conId = getConstrId constr arity = constrArity constr priority = toInteger (tPriority conId) priorityPlus1 = priority+1 -- ---------------------------------------------------------------------------- deriveIx :: Pos -> [Context TraceId] -> TraceId -> Instance TraceId -> [Constr TraceId] -> Decl TraceId deriveIx pos contexts cls ty constrs = DeclInstance pos contexts cls [ty] (if all (== 0) (map constrArity constrs) then (DeclsParse [DeclFun pos (modArity (dropModule tTokenRange) 1) [Fun [ExpApplication pos [ExpCon pos tTokenTuple2,lvar,uvar]] (Unguarded (ExpApplication pos [ExpVar pos tTokenMap,toEnumVar ,ExpApplication pos [ExpVar pos tTokenEnumFromTo ,ExpApplication pos [fromEnumVar,lvar] ,ExpApplication pos [fromEnumVar,uvar]]])) (DeclsParse (declsToEnum ++ declsFromEnum))] ,DeclFun pos (modArity (dropModule tTokenIndex) 2) [Fun [ExpApplication pos [ExpCon pos tTokenTuple2,lvar,uvar],ivar] (Unguarded (ExpApplication pos [ExpVar pos tTokenMinus ,ExpApplication pos [fromEnumVar,ivar] ,ExpApplication pos [fromEnumVar,lvar]])) (DeclsParse declsFromEnum)] ,DeclFun pos (modArity (dropModule tTokenInRange) 2) [Fun [ExpApplication pos [ExpCon pos tTokenTuple2,lvar,uvar],ivar] (Unguarded (ExpApplication pos [ExpVar pos tTokenInRange ,ExpApplication pos [ExpCon pos tTokenTuple2 ,ExpApplication pos [fromEnumVar,lvar] ,ExpApplication pos [fromEnumVar,uvar]] ,ExpApplication pos [fromEnumVar,ivar]])) (DeclsParse declsFromEnum)] ]) else {- exactly one constructor -} (DeclsParse [DeclFun pos (modArity (dropModule tTokenRange) 1) [Fun [ExpApplication pos [ExpCon pos tTokenTuple2,conLvars,conUvars]] (Unguarded (foldr ($) (ExpApplication pos [ExpVar pos tTokenReturn,conIvars]) (zipWith3 rangeComb lvars uvars ivars))) noDecls] ,DeclFun pos (modArity (dropModule tTokenIndex) 2) [Fun [ExpApplication pos [ExpCon pos tTokenTuple2,conLvars,conUvars] ,conIvars] (Unguarded (foldl (flip ($)) (indexExp (head lvars) (head uvars) (head ivars)) (tail (zipWith3 indexComb lvars uvars ivars)))) noDecls] ,DeclFun pos (modArity (dropModule tTokenInRange) 2) [Fun [ExpApplication pos [ExpCon pos tTokenTuple2,conLvars,conUvars] ,conIvars] (Unguarded (foldr1 andExp (zipWith3 inRangeExp lvars uvars ivars))) noDecls] ])) where -- for enumeration type lvar:uvar:ivar:_ = traceVars pos fromEnumVar = ExpVar pos tTokenLocalFromEnum toEnumVar = ExpVar pos tTokenLocalToEnum declsFromEnum :: [Decl TraceId] declsFromEnum = [DeclVarsType [(pos,tTokenLocalFromEnum)] [] (TypeCons pos tTokenFun [ty,TypeCons pos tTokenInt []]) ,DeclFun pos tTokenLocalFromEnum (zipWith funFromEnum constrs [0..])] declsToEnum = [DeclVarsType [(pos,tTokenLocalToEnum)] [] (TypeCons pos tTokenFun [TypeCons pos tTokenInt [],ty]) ,DeclFun pos tTokenLocalToEnum (zipWith funToEnum constrs [0..])] funFromEnum constr num = Fun [ExpCon pos (getConstrId constr)] (Unguarded (ExpLit pos (LitInteger Boxed num))) noDecls funToEnum constr num = Fun [ExpLit pos (LitInteger Boxed num)] (Unguarded (ExpCon pos (getConstrId constr))) noDecls -- for single constructor type [constr] = constrs conId = getConstrId constr arity = constrArity constr (lvars,vars1) = splitAt arity (traceVars pos) (uvars,vars2) = splitAt arity vars1 ivars = take arity vars2 conLvars = ExpApplication pos (ExpCon pos conId:lvars) conUvars = ExpApplication pos (ExpCon pos conId:uvars) conIvars = ExpApplication pos (ExpCon pos conId:ivars) rangeComb :: Exp TraceId -> Exp TraceId -> Exp TraceId -> Exp TraceId -> Exp TraceId rangeComb l u i cont = ExpApplication pos [ExpVar pos tTokenGtGtEq ,ExpApplication pos [ExpVar pos tTokenRange ,ExpApplication pos [ExpCon pos tTokenTuple2,l,u]] ,ExpLambda pos [i] cont] indexExp l u i = ExpApplication pos [ExpVar pos tTokenIndex ,ExpApplication pos [ExpCon pos tTokenTuple2,l,u] ,i] indexComb :: Exp TraceId -> Exp TraceId -> Exp TraceId -> Exp TraceId -> Exp TraceId indexComb l u i e = ExpApplication pos [ExpVar pos tTokenPlus ,indexExp l u i ,ExpApplication pos [ExpVar pos tTokenTimes ,ExpApplication pos [ExpVar pos tTokenRangeSize ,ExpApplication pos [ExpCon pos tTokenTuple2,l,u]] ,e]] inRangeExp l u i = ExpApplication pos [ExpVar pos tTokenInRange ,ExpApplication pos [ExpCon pos tTokenTuple2,l,u] ,i] andExp :: Exp TraceId -> Exp TraceId -> Exp TraceId andExp e1 e2 = ExpApplication pos [ExpVar pos tTokenAndAnd,e1,e2] -- ---------------------------------------------------------------------------- -- helper functions -- infinite list of variables -- only need not conflict with names of standard class methods traceVars :: Pos -> [Exp TraceId] traceVars pos = map (ExpVar pos . mkLambdaBound defaultAuxInfo . mkUnqualifiedTokenId . ('y':) . show) [1..]